Welcome

Summary

About this Document

This document is an interactive dashboard viewable from most modern internet browsers. The dashboard is a validation and diagnostics tool for Activity Based Models. Users can compare model performance against a household survey as part of a validation exercise or compare two model runs for sensitivity testing. All of the data, charts, and maps viewable in this dashboard are embedded directly into the HTML file. An internet connection is necessary for the best user experience, but is not required.

Users may navigate to different areas of the dashboard using the navigation bar at the top of the page, and may interact directly with most tables, charts, and maps.

This document is best viewed using the most recent versions of the following web browsers:

Note: Mozilla Firefox does not correctly render the images in this HTML file.

Summary

Modeling Region

Overview

Base Highlights

Survey

Base Population

9,080,188

Base Households

3,621,569

Base Tours

13,327,557

Base Trips

36,754,386

Base Stops

11,709,155

Base VMT

169,449,060

Build Highlights

ASim

Build Population

10,360,958

Build Households

4,094,428

Build Tours

17,568,677

Build Trips

47,625,396

Build Stops

12,488,042

Build VMT

204,710,509

Chart Column 1

Person Type Distribution

Household Size Distribution

Base Highlights2

Survey

Tours per Person

Trips per Person

Stops per Person

Trips per Household

Build Highlights2

ASim

Tours per Person

Trips per Person

Stops per Person

Trips per Household

Long Term Models

Chart Column 1

Auto Ownership

Percentage Working From Home

Chart Column 2

Mandatory TLFD

Flows & Tour Lengths

Chart Column 1

County - County Flow of Workers
2015 - 2019 ACS Commuting Flows
X Boone Cook DeKalb DuPage Grundy Kane Kankakee LaPorte Lake..IL Kendall Kenosha LaSalle Lake..IN Lee McHenry Ogle Porter Racine Walworth Will Winnebago Total
Boone 6,885 1,441 349 726 0 1,595 0 0 104 2 0 0 0 56 2,271 85 0 36 166 128 8,960 22,804
Cook 125 2,033,788 790 141,403 640 19,606 1,631 286 64,445 630 699 292 15,887 69 4,860 96 683 204 173 42,670 845 2,329,822
DeKalb 298 2,056 28,858 3,197 53 7,676 16 0 305 1,926 5 417 38 79 623 661 3 0 25 488 1,056 47,780
DuPage 52 138,947 578 266,626 193 19,186 42 0 6,966 1,595 25 89 730 26 755 87 61 12 10 13,984 112 450,076
Grundy 21 1,882 5 1,066 9,877 238 247 0 2 378 0 961 109 0 0 12 0 0 0 7,495 7 22,300
Kane 376 44,221 1,979 46,216 216 127,455 11 124 3,687 5,099 20 237 194 0 6,645 97 0 12 53 3,972 613 241,227
Kankakee 0 4,620 12 455 341 105 35,709 6 70 0 0 57 357 0 0 15 93 0 0 4,424 0 46,264
LaPorte 0 1,022 0 35 0 2 0 30,735 6 0 0 6 2,528 0 0 0 4,857 0 0 58 0 39,249
Lake, IL 50 77,823 75 7,299 0 1,974 0 0 227,589 10 4,635 24 168 0 7,538 0 0 729 176 543 160 328,793
Kendall 0 5,865 1,491 15,642 752 11,372 0 0 229 15,403 0 424 13 0 85 0 0 0 0 6,420 9 57,705
Kenosha 42 3,465 80 332 0 126 0 0 15,535 16 41,540 0 0 0 1,241 0 10 8,472 1,128 28 25 72,040
LaSalle 1 620 1,249 1,077 1,407 1,694 42 11 7 2,039 0 34,530 44 196 27 145 2 0 0 1,323 89 44,503
Lake, IN 18 42,490 0 2,101 73 130 416 1,480 332 11 0 39 139,997 0 23 0 10,183 16 0 3,772 17 201,098
Lee 33 149 591 156 0 242 0 3 14 131 0 616 0 8,971 26 1,422 0 0 2 67 261 12,684
McHenry 594 32,627 238 5,721 0 12,132 0 0 20,284 27 565 51 94 0 72,367 104 4 146 1,091 310 1,250 147,605
Ogle 441 266 1,936 276 18 292 5 0 13 10 40 69 31 1,749 60 11,716 4 0 5 74 5,117 22,122
Porter 0 5,149 0 221 33 2 0 3,843 109 0 0 4 22,431 0 26 0 40,880 0 0 308 0 73,006
Racine 24 621 0 71 0 0 0 0 1,642 0 7,040 0 8 0 18 0 0 55,842 1,781 28 7 67,082
Walworth 105 934 12 154 3 143 3 0 1,133 3 838 0 0 0 2,139 3 0 2,495 30,607 11 229 38,812
Will 0 89,460 108 56,335 3,583 5,632 2,264 9 1,166 2,605 8 344 2,740 35 327 44 212 65 0 150,959 57 315,953
Winnebago 6,395 1,755 1,092 496 5 1,030 0 0 159 39 0 69 37 119 1,409 1,646 0 27 197 56 104,488 119,019
Total 15,460 2,489,201 39,443 549,605 17,194 210,632 40,386 36,497 343,797 29,924 55,415 38,229 185,406 11,300 100,440 16,133 56,992 68,056 35,414 237,118 123,302 4,699,944

Average Mandatory Tour Lengths
Survey
Home District Work University School
Cook 10.76 9.33 3.57
DeKalb 10.44 5.11 6.21
DuPage 12.85 12.84 3.67
Grundy 17.29 24.12 4.49
Kane 14.12 22.27 5.56
Kendall 15.37 24.61 4.67
Lake, IL 13.76 17.92 4.80
Lake, IN 17.22 16.48 5.36
LaPorte 16.68 18.59 6.78
McHenry 16.31 16.21 4.77
Porter 17.20 15.30 4.56
Will 16.22 21.09 4.89
Total 12.49 11.79 4.15

Chart Column 1

County - County Flow of Workers
ASim
X Boone Cook DeKalb DuPage Grundy Kane Kankakee Lake..IL LaPorte Kendall Kenosha Lake..IN LaSalle Lee McHenry Ogle Porter Racine Walworth Will Winnebago Total
Boone 9,959 838 744 230 0 885 0 321 0 16 36 0 4 5 1,990 90 0 14 288 22 9,502 24,944
Cook 97 2,151,208 292 126,696 172 14,665 704 37,394 141 1,205 533 9,096 31 2 2,279 6 1,408 206 61 33,095 172 2,379,463
DeKalb 670 2,179 29,734 2,653 46 6,553 3 204 0 1,502 11 5 571 67 1,118 414 0 4 39 901 1,268 47,942
DuPage 26 96,596 479 312,206 163 14,192 45 3,633 3 4,085 65 598 63 4 1,503 11 33 20 5 10,254 55 444,039
Grundy 0 1,614 45 1,110 12,336 578 319 10 0 858 1 92 468 0 10 0 7 0 0 5,978 0 23,426
Kane 245 29,953 2,264 38,269 97 144,557 16 3,525 1 7,335 72 81 143 6 4,510 66 5 23 100 2,263 407 233,938
Kankakee 0 1,858 3 396 294 64 37,169 8 4 63 0 1,295 20 0 3 0 84 0 0 4,021 0 45,282
Lake, IL 83 66,284 50 6,293 3 3,399 1 239,580 1 45 2,456 93 1 1 4,745 2 5 1,923 543 496 128 326,132
LaPorte 0 2,032 0 74 1 11 7 5 34,567 0 0 3,342 1 0 0 0 7,018 0 0 150 0 47,208
Kendall 12 4,113 671 14,209 463 12,492 21 92 0 17,817 1 44 489 10 152 11 4 1 1 6,409 15 57,027
Kenosha 17 3,318 10 269 0 197 1 16,385 0 3 48,634 5 1 0 2,417 0 1 3,090 1,176 22 37 75,583
Lake, IN 0 45,708 1 1,412 26 83 538 92 616 34 1 153,799 1 0 7 0 9,960 0 0 5,280 0 217,558
LaSalle 24 946 1,437 1,101 1,379 1,408 62 6 0 2,264 1 31 35,127 178 38 127 2 1 1 2,567 158 46,858
Lee 26 34 413 92 8 206 0 0 0 94 0 0 379 301 10 282 0 0 0 62 205 2,112
McHenry 992 21,048 596 3,615 1 13,623 1 14,509 0 145 1,812 13 8 0 82,655 16 0 530 1,615 246 1,264 142,689
Ogle 260 165 1,264 197 2 494 0 15 0 63 0 0 66 100 101 3,964 0 2 7 52 2,497 9,249
Porter 0 4,953 0 250 3 20 39 17 3,164 1 1 19,805 0 0 0 0 47,799 1 0 708 1 76,762
Racine 23 1,739 4 142 0 129 0 3,073 0 2 12,230 6 0 0 1,252 1 0 65,879 2,388 12 88 86,968
Walworth 487 740 62 152 0 435 0 2,798 0 9 2,294 2 0 0 4,520 4 0 3,231 35,357 11 1,266 51,368
Will 4 68,180 231 54,513 2,121 3,630 1,949 486 23 1,949 17 1,477 264 3 168 1 305 4 2 172,462 11 307,800
Winnebago 6,605 971 875 277 1 1,002 0 372 0 28 46 1 26 22 1,752 719 0 55 628 30 110,283 123,693
Total 19,530 2,504,477 39,175 564,156 17,116 218,623 40,875 322,525 38,520 37,518 68,211 189,785 37,663 699 109,230 5,714 66,631 74,984 42,211 245,041 127,357 4,770,041

Average Mandatory Tour Lengths
ASim
Home District Work University School
Cook 9.26 1.40 4.19
DeKalb 16.66 3.10 9.25
DuPage 10.96 1.73 5.92
Grundy 19.50 4.65 11.34
Kane 12.11 2.21 5.72
Kendall 15.80 3.39 7.49
Lake, IL 12.32 2.13 5.67
Lake, IN 12.63 3.25 6.32
LaPorte 14.96 3.40 6.95
McHenry 14.68 2.68 6.51
Porter 13.88 3.20 6.98
Will 14.43 2.65 6.46
Total 11.10 1.93 5.28

Work Tours

Chart Column 1

Tour Production Comparison

County ACS ASim
Boone 45,608 49,888
Cook 4,659,644 4,758,926
DeKalb 95,560 95,884
DuPage 900,152 888,078
Grundy 44,600 46,852
Kane 482,454 467,876
Kankakee 92,528 90,564
LaPorte 78,498 94,416
Lake, IL 657,586 652,264
Kendall 115,410 114,054
Kenosha 144,080 151,166
LaSalle 89,006 93,716
Lake, IN 402,196 435,116
Lee 25,368 4,224
McHenry 295,210 285,378
Ogle 44,244 18,498
Porter 146,012 153,524
Racine 134,164 173,936
Walworth 77,624 102,736
Will 631,906 615,600
Winnebago 238,038 247,386

Chart Column 1

Tour Attraction Comparison

County ACS ASim
Boone 30,920 39,060
Cook 4,978,402 5,008,954
DeKalb 78,886 78,350
DuPage 1,099,210 1,128,312
Grundy 34,388 34,232
Kane 421,264 437,246
Kankakee 80,772 81,750
LaPorte 72,994 77,040
Lake, IL 687,594 645,050
Kendall 59,848 75,036
Kenosha 110,830 136,422
LaSalle 76,458 75,326
Lake, IN 370,812 379,570
Lee 22,600 1,398
McHenry 200,880 218,460
Ogle 32,266 11,428
Porter 113,984 133,262
Racine 136,112 149,968
Walworth 70,828 84,422
Will 474,236 490,082
Winnebago 246,604 254,714

Zero Auto Households

Summary

Zero Auto Households Census vs Model

Tour Summaries

Chart Column 1

Daily Activity Pattern

Percentage of Households with a Joint Tour

Mandatory Tour Frequency

Chart Column 1

Total Tour Rate (only active Persons)

Persons by Individual Non-Mandatory Tours

Joint Tours

Chart Column 1

Joint Tour Frequency

Joint Tour Composition

Chart Column 1

Joint Tours By Number of Household Members

Joint Tours by Household Size

Party Size Distribution by Joint Tour Composition

Destination

Chart Column 1

Non-Mandatory Tour Length Distribution

Average Non-Mandatory Tour Lengths (Miles)

Purpose Survey ASim
Escorting 4.50 3.91
Indi-Maintenance 7.25 5.81
Indi-Discretionary 6.04 6.79
Joint-Maintenance 6.82 6.05
Joint-Discretionary 7.09 7.10
At-Work 3.85 4.12
Total 6.16 5.61

TOD

Chart Column 1

Tour Departure-Arrival Profile

Tour Aggregate Departure-Arrival Profile

Tour Mode

Chart Column 1

Tour Mode Choice


Tour Mode Choice

Results of Tour Mode Choice Models, which selects a primary mode for each tour.

Distribution of tours by tour mode and the ratio of autos to drivers in the household.

Chart Column 2

Chart Column 3

Stop Frequency

Chart Column 1

Stop Frequency - Directional

Chart Column 1

Stop Frequency - Total

Stop Purpose by Tour Purpose

Location

Chart Column 1

Stop Location - Out of Direction Distance

Chart Column 1

Average Out of Direction Distance (Miles)

_______________________________________________________
Tour_Purpose Survey ASim
Work 4.14 2.87
University 3.41 3.77
School 4.76 3.36
Escorting 4.08 3.28
Indi-Maintenance 4.23 3.58
Indi-Discretionary 4.72 4.13
Joint-Maintenance 3.49 3.34
Joint-Discretionary 4.01 3.94
At-Work 3 2.59
Total 4.14 3.26

TOD

Chart Column 1

Stop & Trip Departure

Aggregate Stop & Trip Departure

Trip Mode

Chart Column 1

Trip Mode Choice

The results of the Trip Mode Choice Model, which predicts the mode of each trip on the tour.

Distribution of trips by trip mode and tour mode, which constrains the availability of each trip mode and influences the utility of each available trip mode.

Trip Mode Choice

Chart Column 2

Count vs Volume: All Day

Chart Column 2

RMSE Statistics

Assigned VMT Statistics

Count vs Volume: NT

Chart Column 2

RMSE Statistics

Assigned VMT Statistics

Count vs Volume: EA

Chart Column 2

RMSE Statistics

Assigned VMT Statistics

Count vs Volume: AM

Chart Column 2

RMSE Statistics

Assigned VMT Statistics

Count vs Volume: MM

Chart Column 2

RMSE Statistics

Assigned VMT Statistics

Count vs Volume: MD

Chart Column 2

RMSE Statistics

Assigned VMT Statistics

Count vs Volume: AF

Chart Column 2

RMSE Statistics

Assigned VMT Statistics

Count vs Volume: PM

Chart Column 2

RMSE Statistics

Assigned VMT Statistics

Count vs Volume: EV

Chart Column 2

RMSE Statistics

Assigned VMT Statistics

---
title: "`r paste(BASE_SCENARIO_NAME, 'vs.', BUILD_SCENARIO_NAME, 'Calibration Summary')`"
output:
  flexdashboard::flex_dashboard:
    orientation: columns
    vertical_layout: fill
    theme: spacelab
    social: menu
    source_code: embed
runtime: shiny
---

```{r Setup}
opts_knit$set(root.dir = SYSTEM_APP_PATH)
knit_hooks$set(optipng = hook_optipng)
```

```{r setpar}
knitr::opts_knit$set(global.par = TRUE)
```


```{r ggplot_Theme}
theme_db <- theme_bw() + theme(plot.margin = unit(c(10,10,20,10),"pt"))
```

```{r Helper_Functions}
compare_bar_plotter <- function(base, build, base_name, build_name, xvar, yvar,
                        xlabel = xvar, ylabel = yvar, position = "dodge",
                        xrotate = FALSE, yrotate = FALSE, coord_flip = FALSE,
                        title = "", left_offset = 0, bottom_offset = 0){

  base$grp <- base_name
  build$grp <- build_name
  colnames(build) <- colnames(base)

  df <- rbind(base, build)

  p <- ggplot(df, aes_string(x = xvar, y = yvar)) +
    geom_bar(stat = "identity", aes(fill = grp), position = position) +
    xlab(xlabel) + ylab(ylabel) +
    labs(fill = "") +
    ggtitle(title) +
    theme(axis.text.x=element_text(angle=50, size=1, vjust=0.5)) +
    theme(axis.text.y=element_text(angle=50, size=1, vjust=0.5)) +
    theme_bw()

  if (xrotate) {
    p <- p + theme(axis.text.x = element_text(angle = 45, hjust = 1))
  }
  if (yrotate) {
    p <- p + theme(axis.text.y = element_text(angle = 45, hjust = 1))
  }
  if (coord_flip) {
    p <- p + coord_flip()
  }


  p <- plotly_build(p)
  p$layout$margin$l <- p$layout$margin$l+left_offset
  p$layout$margin$b <- p$layout$margin$b+bottom_offset
  return(p)

}

# This function combines two dataframes and returns a data frame with standard field names
# The field names in the two dataframes should be same and should be same as the variable
# names passed to the function
# input parameter - dataframe1, dataframe2, x variable, list of y variables
# renames x and y variables in standard form - xvar, (yvar1, yvar2),...
# Y variables are named in pairs - (yvar1, yvar2), (yvar3, yvar4), ....
# yvar1, yvar3, .. correspond to first dataframe and yvar2, yvar4, .. correspond to second dataframe
# computes proportions for each  y variable variable
get_standardDF <- function(data_df1, data_df2, x, y, grp = "", shared = F){

  #data_df1=base_df
  #data_df2=build_df
  #x="id"
  #y = c("freq_out", "freq_inb")
  #grp = "purpose"
  #shared = T
  #
  # create ID variable to join base and build data
  if(!shared){
    ev1 <- paste("data_df1$id_var <- data_df1$", x, sep = "")
    ev2 <- paste("data_df2$id_var <- data_df2$", x, sep = "")
    eval(parse(text = ev1))
    eval(parse(text = ev2))
  }else{
    if(grp==""){
      stop("group variable not specified")
    }else{
      ev1 <- paste("data_df1$id_var <- paste(data_df1$", grp, ", data_df1$", x, ', sep = "")', sep = "")
      ev2 <- paste("data_df2$id_var <- paste(data_df2$", grp, ", data_df2$", x, ', sep = "")', sep = "")
      eval(parse(text = ev1))
      eval(parse(text = ev2))
    }
  }

  data_df <- data_df1

  # rename variables to standard names
  names(data_df)[names(data_df) == x] <- 'xvar'
  if(shared){
    if(grp==""){
      stop("group variable not specified")
    }else{
      names(data_df)[names(data_df) == grp] <- 'grp_var'
    }
  }

  for(i in seq(from=1, to=length(y))){
    start_pos <- i*2-1
    yvar1 <- paste('yvar', start_pos, sep = "")
    yvar2 <- paste('yvar', start_pos+1, sep = "")
    names(data_df)[names(data_df) == y[[i]]] <- paste('yvar', start_pos, sep = "")
    eval_expr <- paste("data_df$", yvar2, " <- data_df2$", y[[i]], "[match(data_df$id_var, data_df2$id_var)]", sep = "")
    eval(parse(text = eval_expr))
  }
  
  data_df[is.na(data_df)] <- 0

  #data_df$grp_var <- as.character(data_df$grp_var)

  # compute proportions for y variables
  for(i in seq(from=1, to=length(y))){
    start_pos <- i*2-1
    prop_var1 <- paste('prop', start_pos, sep = "")
    y_var1    <- paste('yvar', start_pos, sep = "")
    prop_var2 <- paste('prop', start_pos+1, sep = "")
    y_var2    <- paste('yvar', start_pos+1, sep = "")
    if(shared){
      if(grp==""){
        stop("group variable not specified")
      }else{
        eval_expr1 <- paste("data_df <- data_df %>% group_by(grp_var) %>% mutate(", prop_var1, " = prop.table(", y_var1, "))", sep = "")
        eval_expr2 <- paste("data_df <- data_df %>% group_by(grp_var) %>% mutate(", prop_var2, " = prop.table(", y_var2, "))", sep = "")
      }
    }else{
      eval_expr1 <- paste("data_df <- data_df %>% mutate(", prop_var1, " = prop.table(", y_var1, "))", sep = "")
      eval_expr2 <- paste("data_df <- data_df %>% mutate(", prop_var2, " = prop.table(", y_var2, "))", sep = "")
    }

    eval(parse(text = eval_expr1))
    eval(parse(text = eval_expr2))
  }

  # set all NAs to zero
  # data_df[is.na(data_df)] <- 0

  if(!shared){
    return(data_df)
  }else{
    data_sd <- SharedData$new(data_df, ~grp_var)
    return(data_sd)
  }
}

# This function returns a SharedData object for creating comparison density plots
# input parameter - dataframe1, dataframe2, x variable, list of y variables,
# grouping variable, names of each run
# The function expects same field names across both dataframes
# renames x and y variables in standard form - xvar, yvar1, yvar2,...
# computes proportions for each  y variable variable for each group and run
# combines two dataframe and adds a run identifier
get_sharedData <- function(data_df1, data_df2, run1_name = 'base', run2_name = 'build',
                           x, y, grp){

  # rename variables to standard names
  names(data_df1)[names(data_df1) == x] <- 'xvar'
  names(data_df1)[names(data_df1) == grp] <- 'grp_var'
  for(i in 1:length(y)){
    names(data_df1)[names(data_df1) == y[[i]]] <- paste('yvar', i, sep = "")
  }

  names(data_df2)[names(data_df2) == x] <- 'xvar'
  names(data_df2)[names(data_df2) == grp] <- 'grp_var'
  for(i in 1:length(y)){
    names(data_df2)[names(data_df2) == y[[i]]] <- paste('yvar', i, sep = "")
  }

  # compute proportions for y variables
  data_df1 <- group_by(data_df1, grp_var)
  for(i in 1:length(y)){
    prop_var <- paste('prop', i, sep = "")
    y_var    <- paste('yvar', i, sep = "")
    eval_expr <- paste("data_df1 <- data_df1 %>% mutate(", prop_var, " = prop.table(", y_var, "))", sep = "")
    eval(parse(text = eval_expr))
  }

  data_df2 <- group_by(data_df2, grp_var)
  for(i in 1:length(y)){
    prop_var <- paste('prop', i, sep = "")
    y_var    <- paste('yvar', i, sep = "")
    eval_expr <- paste("data_df2 <- data_df2 %>% mutate(", prop_var, " = prop.table(", y_var, "))", sep = "")
    eval(parse(text = eval_expr))
  }

  # add run identifiers
  data_df1$run <- run1_name
  data_df2$run <- run2_name

  # combine dataframes
  data_df <- rbind(data_df1, data_df2)

  # set all NAs to zero
  data_df[is.na(data_df)] <- 0

  data_sd <- SharedData$new(data_df, ~grp_var)
  return(data_sd)
}

# This function returns bar plot for a given X-Y data frame
# The function expects the data frame columns to be named as
# xvar, yvar1, yvar2...
# function plots only two series at a time
# which two y series to plot is determined by the index variable
# index==1 :- yvar1, yvar2, index==2 :- yvar,3,4 and so on
# names of series to be plotted should also be passed as a list argument
# number of elements in names list determines the number of series to be added
plotly_bar_plotter <- function(data, type = 'bar', xlabel = "", ylabel = "", percent = FALSE,
                               title = "", height = 0, width = 0, ynames = c(""), left_offset = 0,
                               bottom_offset = 0, tickformat = "", hoverformat = "", tickangle = 0, index = 1, tickvals = c(), ticktext = c()){
  #initial setup
  start_pos <- 2*index - 1
  exp_tickvals <- ifelse(length(tickvals)>0, ', tickvals = tickvals', "")
  exp_ticktext <- ifelse(length(ticktext)>0, ', ticktext = ticktext', "")

  #generate plot
  if(!percent){
    ylab <- ifelse(ylabel=="", "Percent", ylabel)
    hformat <- ifelse(hoverformat=="", '.1f', hoverformat)
    eval_expr <- paste("p <- plot_ly(data, x = ~xvar, y = ~yvar", start_pos, ", type = type, name = ynames[[1]]) %>% ",
                       "add_trace(y = ~yvar", start_pos+1, ", name = ynames[[2]]) %>% ",
                       "layout(yaxis = list(hoverformat = hformat, title = ylab, tickformat = tickformat), xaxis = list(title = xlabel, tickangle = tickangle", exp_tickvals, exp_ticktext, "), barmode = 'group')", sep = "")
    eval(parse(text = eval_expr))
  }else{
    ylab <- ifelse(ylabel=="", "Frequency", ylabel)
    hformat <- ifelse(hoverformat=="", '.1%', hoverformat)
    eval_expr <- paste("p <- plot_ly(data, x = ~xvar, y = ~prop", start_pos, ", type = type, name = ynames[[1]]) %>% ",
                       "add_trace(y = ~prop", start_pos+1, ", name = ynames[[2]]) %>% ",
                       "layout(yaxis = list(hoverformat = hformat, title = ylab, tickformat = '.0%'), xaxis = list(title = xlabel, tickangle = tickangle", exp_tickvals, exp_ticktext,"), barmode = 'group')", sep = "")
    eval(parse(text = eval_expr))
  }

  p$x$layout$height <- height
  p$x$layout$width <- width
  p$x$layout$margin$b <- p$x$layout$margin$b + bottom_offset
  p$x$layout$margin$l <- p$x$layout$margin$l + left_offset
  return(p)
}

# This function returns a spline plot with fill for a gievn X-Y dataframe
# The function expects the data frame columns to be named as
# x = ~xvar, y = (~yvar1 or prop1),  (~yvar2 or prop2) adn so on (Frequency or Percent),
# which y to use is determined by index parameter (one, two or three)
# and variable differentiating runs as ~run
# The function currebtly plots only one Y variables for each run
plotly_density_plotter <- function(data_df, index = "one", colors=c("orange", "steelblue"), fill = 'tozeroy',
                                   title = "", xlabel = "", ylabel = "", percent = T, alpha = 0.7, tickvals, ticktext, tickangle = 0,
                                   height=400, left_offset = 0, bottom_offset = 0, shape = 'spline', legend = T){
  ##standardize data frame
  #names(data_df)[names(data_df)==xvar]     <- 'xvar'
  #names(data_df)[names(data_df)==yvar]     <- 'yvar1'
  #names(data_df)[names(data_df)==prop_var] <- 'prop1'
  #names(data_df)[names(data_df)==grp]      <- 'run'

  # prepare plot using standardized dataframe
  if(percent){
    ylab <- ifelse(ylabel=="", "Percent", ylabel)

    p <- switch(index,
                "one" = plot_ly(data=data_df,x = ~xvar, y = ~prop1, colors=c("orange", "steelblue"), color = ~run, fill=fill) %>%
                  add_lines(name=~run,alpha=alpha, line = list(shape = shape)) %>%
                  layout(title = "",xaxis = list(title=xlabel, tickvals = tickvals, ticktext = ticktext, tickangle = tickangle), yaxis = list(title=ylab, tickformat = ".0%"), showlegend = legend),
                "two" = plot_ly(data=data_df,x = ~xvar, y = ~prop2, colors=c("orange", "steelblue"), color = ~run, fill=fill) %>%
                  add_lines(name=~run,alpha=alpha, line = list(shape = shape)) %>%
                  layout(title = "",xaxis = list(title=xlabel, tickvals = tickvals, ticktext = ticktext, tickangle = tickangle), yaxis = list(title=ylab, tickformat = ".0%"), showlegend = legend),
                "three" = plot_ly(data=data_df,x = ~xvar, y = ~prop3, colors=c("orange", "steelblue"), color = ~run, fill=fill) %>%
                  add_lines(name=~run,alpha=alpha, line = list(shape = shape)) %>%
                  layout(title = "",xaxis = list(title=xlabel, tickvals = tickvals, ticktext = ticktext, tickangle = tickangle), yaxis = list(title=ylab, tickformat = ".0%"), showlegend = legend)
                )

  }else{
    ylab <- ifelse(ylabel=="", "Frequency", ylabel)

    p <- switch(index,
                "one" = plot_ly(data=data_df,x = ~xvar, y = ~yvar1, colors=c("orange", "steelblue"), color = ~run, fill=fill) %>%
                  add_lines(name=~run,alpha=alpha, line = list(shape = shape)) %>%
                  layout(title = "",xaxis = list(title=xlabel, tickvals = tickvals, ticktext = ticktext, tickangle = tickangle), yaxis = list(title=ylab), showlegend = legend),
                "two" = plot_ly(data=data_df,x = ~xvar, y = ~yvar2, colors=c("orange", "steelblue"), color = ~run, fill=fill) %>%
                  add_lines(name=~run,alpha=alpha, line = list(shape = shape)) %>%
                  layout(title = "",xaxis = list(title=xlabel, tickvals = tickvals, ticktext = ticktext, tickangle = tickangle), yaxis = list(title=ylab), showlegend = legend),
                "three" = plot_ly(data=data_df,x = ~xvar, y = ~yvar3, colors=c("orange", "steelblue"), color = ~run, fill=fill) %>%
                  add_lines(name=~run,alpha=alpha, line = list(shape = shape)) %>%
                  layout(title = "",xaxis = list(title=xlabel, tickvals = tickvals, ticktext = ticktext, tickangle = tickangle), yaxis = list(title=ylab), showlegend = legend)
                )

    #p <- plot_ly(data=data_df,x = ~xvar, y = ~yvar1, colors=c("orange", "steelblue"), color = ~run, height=400, fill=fill) %>%
    #add_lines(name="",alpha=alpha, line = list(shape = shape)) %>%
    #layout(title = "",xaxis = list(title=xlabel), yaxis = list(title=ylab))
  }

  p$x$layout$height <- height
  p$x$layout$margin$b <- p$x$layout$margin$b + bottom_offset
  p$x$layout$margin$l <- p$x$layout$margin$l + left_offset
  return(p)
}

# This function returns a pie chart
# Input is a 2 column data frame with a label variable and a value variable
plotly_pie_chart <- function(data, label_var, value_var, title = "",
                               height = 0, width = 0, left_offset = 0,bottom_offset = 0, top_offset = 0, shared = F){

  colors <- c('rgb(211,94,96)', 'rgb(128,133,133)', 'rgb(144,103,167)', 'rgb(171,104,87)', 'rgb(114,147,203)')

  if(!shared){
    names(data)[names(data)==label_var] <- 'label_var'
    names(data)[names(data)==value_var] <- 'value_var'

    p <- plot_ly(data, labels = ~label_var, values = ~value_var, type = 'pie',
          textposition = 'outside',
          textinfo = 'label+percent',
          insidetextfont = list(color = '#FFFFFF'),
          marker = list(colors = colors,
                        line = list(color = '#FFFFFF', width = 2)),
          showlegend = FALSE,
          sort = FALSE) %>%
    layout(title = title,
           xaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE),
           yaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE))
  }else{
    eval_expr <- paste("p <- plot_ly(data, labels = ~", label_var, ", values = ~", value_var, ", type = 'pie',
          textposition = 'outside',
          textinfo = 'label+percent',
          insidetextfont = list(color = '#FFFFFF'),
          marker = list(colors = colors,
                        line = list(color = '#FFFFFF', width = 2)),
          showlegend = FALSE,
          sort = FALSE) %>%
    layout(title = title,
           xaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE),
           yaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE))", sep = "")

    eval(parse(text = eval_expr))
  }


  p$x$layout$height <- height
  p$x$layout$width <- width
  p$x$layout$margin$b <- p$x$layout$margin$b + bottom_offset
  p$x$layout$margin$l <- p$x$layout$margin$l + left_offset
  p$x$layout$margin$t <- p$x$layout$margin$t + top_offset
  return(p)
}

lm_eqn <- function(df){
    m <- lm(y ~ x - 1, df);
    eq <- paste("Y = ", format(coef(m)[1], digits = 2), " * X , ", " r2 = ", format(summary(m)$r.squared, digits = 3), sep = "")
    return(eq)
}

```

Welcome
============================================

Summary {data-width=150}
--------------------------------------------

### About this Document

This document is an interactive dashboard viewable from most modern internet browsers. The dashboard is a validation and diagnostics tool for Activity Based Models. Users can compare model performance against a household survey as part of a validation exercise or compare two model runs for sensitivity testing. All of the data, charts, and maps viewable in this dashboard are embedded directly into the HTML file. An internet connection is necessary for the best user experience, but is not required.

Users may navigate to different areas of the dashboard using the navigation bar at the top of the page, and may interact directly with most tables, charts, and maps.

This document is best viewed using the most recent versions of the following web browsers:

* [Google Chrome](https://www.google.com/chrome/browser/desktop/)
* [Microsoft Internet Explorer](https://www.microsoft.com/en-us/download/internet-explorer.aspx)

Note: Mozilla Firefox does not correctly render the images in this HTML file.

Summary {data-width=600}
--------------------------------------------

### Modeling Region
```{r model_region}
# cat("Number of TAZs:", nrow(zone_shp))
# bins <- c(0, 10, 20, 50, 100, 200, 500, 1000, Inf)
# pal <- colorBin("YlOrRd", domain = zone_shp$HH, bins = bins)

m <- leaflet(data = zone_shp)%>%
 addTiles() %>%
 addProviderTiles(providers$OpenStreetMap, group = "Background Map") %>%
 addLayersControl(
   overlayGroups = "Background Map", options = layersControlOptions(collapsed = FALSE)
 ) %>%
 addPolygons(weight = 0.5, opacity = 1)
m

# m <- leaflet(data = zone_shp)%>%
#  addTiles() %>%
#  addProviderTiles(providers$OpenStreetMap, group = "Background Map") %>%
#  addLayersControl(
#    overlayGroups = "Background Map", options = layersControlOptions(collapsed = FALSE)
#  )
# m
#
```


Overview
============================================

Base Highlights {data-width=90}
--------------------------------------------

###

```{r Run_Date1_ValueBox}
valueBox(BASE_SCENARIO_NAME, paste("Sample Rate: ", round(BASE_SAMPLE_RATE*100,2), "%", sep = ""), color = "DarkOrange")
base_pos <- which(base_csv_names=="totals")
base_df <- base_data[[base_pos]]
```

### Base Population
```{r Population1_ValueBox}
valueBox(prettyNum(round(base_df$value[base_df$name=="total_population"]/BASE_SAMPLE_RATE), big.mark = ","), "Population", icon = "ion-ios-people")
```

### Base Households
```{r Household1_ValueBox}
valueBox(prettyNum(round(base_df$value[base_df$name=="total_households"]/BASE_SAMPLE_RATE), big.mark = ","), "Households", icon = "glyphicon glyphicon-home")
```

### Base Tours
```{r Tours1_ValueBox}
valueBox(prettyNum(round(base_df$value[base_df$name=="total_tours"]/BASE_SAMPLE_RATE), big.mark = ","), "Total Tours", icon = "ion-refresh")
```

### Base Trips
```{r Trips1_ValueBox}
valueBox(prettyNum(round(base_df$value[base_df$name=="total_trips"]/BASE_SAMPLE_RATE), big.mark = ","), "Total Trips", icon = "ion-loop")
```

### Base Stops
```{r Stops1_ValueBox}
valueBox(prettyNum(round(base_df$value[base_df$name=="total_stops"]/BASE_SAMPLE_RATE), big.mark = ","), "Total Stops", icon = "ion-ios-location")
```

### Base VMT
```{r VMT1_ValueBox}
valueBox(prettyNum(round(base_df$value[base_df$name=="total_vmt"]/BASE_SAMPLE_RATE), big.mark = ","), "Total VMT", icon = "ion-android-car")
```



Build Highlights {data-width=90}
--------------------------------------------

###

```{r Run_Date2_ValueBox}
valueBox(BUILD_SCENARIO_NAME, paste("Sample Rate: ", round(BUILD_SAMPLE_RATE*100,2), "%", sep = ""), color = "DarkOrange")
build_pos <- which(build_csv_names=="totals")
build_df <- build_data[[build_pos]]
```

### Build Population
```{r Population2_ValueBox}
valueBox(prettyNum(round(build_df$value[build_df$name=="total_population"]/BUILD_SAMPLE_RATE), big.mark = ","), "Population", icon = "ion-ios-people")
```

### Build Households
```{r Household2_ValueBox}
valueBox(prettyNum(format(round(build_df$value[build_df$name=="total_households"]/BUILD_SAMPLE_RATE), scientific=F), big.mark = ","), "Households", icon = "glyphicon glyphicon-home")
```

### Build Tours
```{r Tours2_ValueBox}
valueBox(prettyNum(round(build_df$value[build_df$name=="total_tours"]/BUILD_SAMPLE_RATE), big.mark = ","), "Total Tours", icon = "ion-refresh")
```

### Build Trips
```{r Trips2_ValueBox}
valueBox(prettyNum(round(build_df$value[build_df$name=="total_trips"]/BUILD_SAMPLE_RATE), big.mark = ","), "Total Trips", icon = "ion-loop")
```

### Build Stops
```{r Stops2_ValueBox}
valueBox(prettyNum(round(build_df$value[build_df$name=="total_stops"]/BUILD_SAMPLE_RATE), big.mark = ","), "Total Stops", icon = "ion-ios-location")
```

### Build VMT
```{r VMT2_ValueBox}
valueBox(prettyNum(round(build_df$value[build_df$name=="total_vmt"]/BUILD_SAMPLE_RATE), big.mark = ","), "Total VMT", icon = "ion-android-car")
```


Chart Column 1 {data-width=275}
--------------------------------------------
### Person Type Distribution
```{r Chart_Person_Type}
base_pos <- which(base_csv_names=="pertypeDistbn")
base_df <- base_data[[base_pos]]
base_df$PERNAME <- person_type_df$name_char[match(base_df$PERTYPE, person_type_df$code)]
base_df$PERNAME <- factor(base_df$PERNAME, levels = person_type_char)
build_pos <- which(build_csv_names=="pertypeDistbn")
build_df <- build_data[[build_pos]]
build_df$PERNAME <- person_type_df$name_char[match(build_df$PERTYPE, person_type_df$code)]
build_df$PERNAME <- factor(build_df$PERNAME, levels = person_type_char)

colnames(build_df) <- colnames(base_df)

std_DF <- get_standardDF(data_df1 = base_df, data_df2 = build_df, x = "PERNAME", y = c("freq"))
p <- plotly_bar_plotter(data = std_DF, xlabel = "Person Type", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, bottom_offset = 60, tickangle = -30)
p

```

### Household Size Distribution
```{r Chart_HHSize}
base_pos <- which(base_csv_names=="hhSizeDist")
base_df <- base_data[[base_pos]]

census_df = base_data[[which(base_csv_names=="hhSizeCensus")]]


build_pos <- which(build_csv_names=="hhSizeDist")
build_df <- build_data[[build_pos]]

colnames(census_df) <- colnames(base_df)

std_DF <- get_standardDF(data_df1 = base_df, data_df2 = build_df, x = "HHSIZE", y = c("freq"))
p <- plotly_bar_plotter(data = std_DF, xlabel = "HH Size", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T)
p

```

Base Highlights2 {data-width=90}
--------------------------------------------

###

```{r Run_Date3_ValueBox}
valueBox(BASE_SCENARIO_NAME, "", color = "DarkOrange")
base_pos <- which(base_csv_names=="totals")
base_df <- base_data[[base_pos]]
```


### Tours per Person
```{r TourRate3_Gauge}
rate <- base_df$value[base_df$name=="total_tours"]/base_df$value[base_df$name=="total_population"]
gauge(prettyNum(round(rate, 2), big.mark = ","), min = 0, max = 2, gaugeSectors(danger = c(0,2), colors = c("Green", "Green", "Green")))
```

### Trips per Person
```{r TripRate3_Gauge}
rate <- base_df$value[base_df$name=="total_trips"]/base_df$value[base_df$name=="total_population"]
gauge(prettyNum(round(rate, 2), big.mark = ","), min = 0, max = 5, gaugeSectors(danger = c(0,5), colors = c("Green", "Green", "Green")))
```

### Stops per Person
```{r StopRate3_Gauge}
rate <- base_df$value[base_df$name=="total_stops"]/base_df$value[base_df$name=="total_population"]
gauge(prettyNum(round(rate, 2), big.mark = ","), min = 0, max = 2, gaugeSectors(danger = c(0,2), colors = c("Green", "Green", "Green")))
```

### Trips per Household
```{r TRate3_Gauge}
rate <- base_df$value[base_df$name=="total_trips"]/base_df$value[base_df$name=="total_households"]
gauge(prettyNum(round(rate, 2), big.mark = ","), min = 0, max = 15, gaugeSectors(danger = c(0,15), colors = c("Green", "Green", "Green")))
```


Build Highlights2 {data-width=90}
--------------------------------------------

###

```{r Run_Date4_ValueBox}
valueBox(BUILD_SCENARIO_NAME, "", color = "DarkOrange")
build_pos <- which(build_csv_names=="totals")
build_df <- build_data[[build_pos]]
```


### Tours per Person
```{r TourRate4_Gauge}
rate <- build_df$value[build_df$name=="total_tours"]/build_df$value[build_df$name=="total_population"]
gauge(prettyNum(round(rate, 2), big.mark = ","), min = 0, max = 2, gaugeSectors(danger =  c(0,2), colors = c("Green", "Green", "Green")))
```

### Trips per Person
```{r TripRate4_Gauge}
rate <- build_df$value[build_df$name=="total_trips"]/build_df$value[build_df$name=="total_population"]
gauge(prettyNum(round(rate, 2), big.mark = ","), min = 0, max = 5, gaugeSectors(danger = c(0,5), colors = c("Green", "Green", "Green")))
```

### Stops per Person
```{r StopRate4_Gauge}
rate <- build_df$value[build_df$name=="total_stops"]/build_df$value[build_df$name=="total_population"]
gauge(prettyNum(round(rate, 2), big.mark = ","), min = 0, max = 2, gaugeSectors(danger = c(0,2), colors = c("Green", "Green", "Green")))
```

### Trips per Household
```{r TRate4_Gauge}
rate <- build_df$value[build_df$name=="total_trips"]/build_df$value[build_df$name=="total_households"]
gauge(prettyNum(round(rate, 2), big.mark = ","), min = 0, max = 15, gaugeSectors(danger = c(0,15), colors = c("Green", "Green", "Green")))
```


Long Term Models{data-navmenu="Long Term"}
============================================

Description {.sidebar data-width=225}
--------------------------------------------


**Auto Ownership**

Results of household auto ownership model, which predicts number of vehicles per household.

**Mandatory TLFD**

Results of work and school location choice models.

Distribution of workers by distance between home and usual work place, and students by distance between home and school location.

Chart Column 1 {data-width=300}
--------------------------------------------
### Auto Ownership{data-height=265}
```{r Chart_Auto_Ownership}
if(IS_BASE_SURVEY=="Yes"){
  #cat("Census source: ", AO_CENSUS_LONG)
  # [3/31/2020] DH No census data used for SEMCOG
  census_df <- base_data[[which(base_csv_names=="autoOwnershipCensus")]]
  # base_df <- base_data[[which(base_csv_names=="autoOwnership")]]
  base_df <- base_data[[which(base_csv_names=="autoOwnership")]]

}else{
  base_df <- base_data[[which(base_csv_names=="autoOwnership")]]
}

build_df <- build_data[[which(build_csv_names=="autoOwnership")]]
build_df$X = NULL
base_df$X = NULL
#colnames(build_df) <- colnames(census_df)
#colnames(base_df) <- colnames(census_df)

base_df$HDISTRICT = levels(base_df$HDISTRICT)[base_df$HDISTRICT]
build_df$HDISTRICT = levels(build_df$HDISTRICT)[build_df$HDISTRICT]

# Limit to surveyed counties
build_df = build_df[build_df$HDISTRICT %in% base_df$HDISTRICT,]

sd.autoown <- get_standardDF(data_df1 = base_df, data_df2 = build_df, x = "HHVEH", y = c("freq"), grp = "HDISTRICT", shared = T)

p <- plotly_bar_plotter(data = sd.autoown, xlabel = "Number of Vehicles", ylabel = "Percent", ynames = c(AO_CENSUS_LONG, BUILD_SCENARIO_NAME), percent = T, height = 225)

bscols(widths=c(3,9),
  list(
    filter_select("ao_cname", "Select County", sd.autoown, ~grp_var, multiple=F)),
    p
  )

#p
```

### {data-height=140}
```{r Gauge_WFH1}


```

### Percentage Working From Home{data-height=250}
```{r Chart_WFH}
base_df <- base_data[[which(base_csv_names=="wfh_summary")]]
base_df$share <- base_df$WFH/base_df$Workers
build_df <- build_data[[which(build_csv_names=="wfh_summary")]]
build_df$share <- build_df$WFH/build_df$Workers
build_df = build_df[which(str_to_upper(build_df$District) %in% str_to_upper(base_df$District)),]
std_DF <- cbind(base_df[,c("District", "share")], build_df[,c("share")])
colnames(std_DF) <- c("xvar", "prop1", "prop2")
p <- plotly_bar_plotter(data = std_DF, xlabel = "District", ylabel = "Percent WFH", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, height = 275, tickangle = -320, bottom_offset = 25)
p

```



Chart Column 2 {data-width=350}
--------------------------------------------


### Mandatory TLFD{data-height=475}
```{r mandatoryTLFD}
base_df1 <- base_data[[which(base_csv_names=="workTLFD")]]
base_df1 <- melt(base_df1, id = c("distbin"))

base_df2 <- base_data[[which(base_csv_names=="univTLFD")]]
base_df2 <- melt(base_df2, id = c("distbin"))

base_df3 <- base_data[[which(base_csv_names=="schlTLFD")]]
base_df3 <- melt(base_df3, id = c("distbin"))

base_df <- cbind(base_df1, base_df2$value, base_df3$value)
colnames(base_df) <- c("distbin","variable","value1","value2","value3")

build_df1 <- build_data[[which(build_csv_names=="workTLFD")]]
build_df1 <- melt(build_df1, id = c("distbin"))

build_df2 <- build_data[[which(build_csv_names=="univTLFD")]]
build_df2 <- melt(build_df2, id = c("distbin"))

build_df3 <- build_data[[which(build_csv_names=="schlTLFD")]]
build_df3 <- melt(build_df3, id = c("distbin"))

build_df <- cbind(build_df1, build_df2$value, build_df3$value)
colnames(build_df) <- c("distbin","variable","value1","value2","value3")

sd.purpose <- get_sharedData(data_df1 = base_df, data_df2 = build_df, run1_name = BASE_SCENARIO_NAME,
                             run2_name = BUILD_SCENARIO_NAME, x = "distbin", y = c("value1", "value2", "value3"), grp = "variable")

p1 <- plotly_density_plotter(sd.purpose, index = "one", xlabel = "Miles to Work", percent = T, tickvals = seq(1,50,5), ticktext = seq(0,50,5), height = 240)
p2 <- plotly_density_plotter(sd.purpose, index = "two", xlabel = "Miles to University", percent = T, tickvals = seq(1,50,5), ticktext = seq(0,50,5), height = 240)
p3 <- plotly_density_plotter(sd.purpose, index = "three", xlabel = "Miles to School", percent = T, tickvals = seq(1,50,5), ticktext = seq(0,50,5), height = 240)

bscols(widths=c(12),
  list(filter_select("Purpose_County", "Select County", sd.purpose, ~grp_var,multiple=F),
  p1,
  p2,
  p3)
  )

```


Flows & Tour Lengths{data-navmenu="Long Term"}
============================================

Description {.sidebar data-width=135}
--------------------------------------------

**County-County Flow of Workers**

Crosstab of workers by home county and usual work place county.

Note: Districts can be Tract, County, District etc.

**Average Tour Lengths**

Average tour length to workplace by District of residence


Chart Column 1
--------------------------------------------

### {data-height=300}
```{r Table1_CountyFlows, eval  = TRUE}
cat("County - County Flow of Workers")

base_df <- base_data[[which(base_csv_names=="countyFlowsCensus")]]


base_df[,!colnames(base_df) %in% c("X")] <- base_df[,!colnames(base_df) %in% c("X")]/BASE_SAMPLE_RATE
t1 <- kable(base_df, format = 'html', caption = DISTRICT_FLOW_CENSUS, digits = 0, row.names = F, align = 'r', format.args = list(big.mark = ',')) %>%
  kable_styling('striped', font_size = 10)
t1

```

### {data-height=280}
```{r Table1_MandTripLengths}
cat("Average Mandatory Tour Lengths")

base_df <- base_data[[which(base_csv_names=="mandTripLengths")]]
df <- base_df
colnames(df) <- c("Home District", "Work","University","School")

eval_expr <- paste("t1 <- kable(df, format = 'html', digits = 2, row.names = F, align = 'r', format.args = list(big.mark = ',')) %>%
  kable_styling('striped', font_size = 10, full_width=F, position='center') %>%
  add_header_above(c(' ' = 1, '", BASE_SCENARIO_NAME, "' = 3))", sep = "")
eval(parse(text = eval_expr))
t1
```


Chart Column 1
-------------------------------------------- 

### {data-height=300}
```{r Table2_CountyFlows, eval = TRUE}
cat("County - County Flow of Workers")

base_df <- base_data[[which(base_csv_names=="countyFlowsCensus")]]

build_pos <- which(build_csv_names=="countyFlows")
build_df <- build_data[[build_pos]]

build_df = build_df[levels(build_df$X) %in% levels(base_df$X),colnames(build_df) %in% colnames(base_df)]


build_df[,!colnames(build_df) %in% c("X")] <- build_df[,!colnames(build_df) %in% c("X")]/BUILD_SAMPLE_RATE
t2 <- kable(build_df, format = 'html', caption = BUILD_SCENARIO_NAME, digits = 0, row.names = F, align = 'r', format.args = list(big.mark = ',')) %>%
  kable_styling('striped', font_size = 10)
t2
```

### {data-height=280}
```{r Table2_MandTripLengths}
cat("Average Mandatory Tour Lengths")

base_df <- base_data[[which(base_csv_names=="mandTripLengths")]]

build_df <- build_data[[which(build_csv_names=="mandTourLengths")]]
df <- build_df[levels(build_df$District)[build_df$District] %in% levels(base_df$District)[base_df$District],]
colnames(df) <- c("Home District", "Work","University","School")

eval_expr <- paste("t2 <- kable(df, format = 'html', digits = 2, row.names = F, align = 'r', format.args = list(big.mark = ',')) %>%
  kable_styling('striped', font_size = 10, full_width=F, position='center') %>%
  add_header_above(c(' ' = 1, '", BUILD_SCENARIO_NAME, "' = 3))", sep = "")
eval(parse(text = eval_expr))
t2
```


Work Tours{data-navmenu="Long Term"}
============================================

Description {.sidebar data-width=135}
--------------------------------------------

**Tour Productions by County**

Comparison of work productions, model vs. ACS Journey-To-Work 2011-2015. NOTE: Other ACS data is 2017, this data is NOT adjusted for date, it is adjusted for work-from-home.

Note: Districts can be Tract, County, District etc.

**Tour Attractions by County**

Comparison of work attractions, model vs. ACS Journey-To-Work 2011-2015. NOTE: Other ACS data is 2017, this data is NOT adjusted for date, it is adjusted for work-from-home.

Chart Column 1
--------------------------------------------
### Tour Production Comparison {data-height=300}
```{r aWorkTourProds}

base_df <- base_data[[which(base_csv_names=="countyFlowsCensus")]]

build_pos <- which(build_csv_names=="countyFlows")
build_df <- build_data[[build_pos]]

build_df = build_df[levels(build_df$X)[build_df$X] %in% levels(base_df$X)[base_df$X],colnames(build_df) %in% colnames(base_df)]

wp_df = data.frame(County = base_df[,"X"], ACSWorkProds = rowSums(base_df[,2:ncol(base_df)]))
wp_dfb = data.frame(County = build_df[,"X"], ModWorkProds = round(rowSums(build_df[,2:ncol(build_df)])/BUILD_SAMPLE_RATE))
wp_df$ModWorkProds = wp_dfb$ModWorkProds[match(levels(wp_df$County)[wp_df$County], levels(wp_dfb$County)[wp_dfb$County])]

wp_df = wp_df[!wp_df$County == "Total",]
wp_df$County = levels(wp_df$County)[wp_df$County]

colnames(wp_df) = c("xvar", "yvar1", "yvar2")

p <- plotly_bar_plotter(data = wp_df, xlabel = "County", ylabel = "Tours", ynames = c(AO_CENSUS_LONG, BUILD_SCENARIO_NAME), percent = F, height = 275, tickangle = -320, bottom_offset = 25)
p

```

### {data-height=280}
```{r aWorkTourProdTable}

base_df <- base_data[[which(base_csv_names=="countyFlowsCensus")]]

build_pos <- which(build_csv_names=="countyFlows")
build_df <- build_data[[build_pos]]

build_df = build_df[levels(build_df$X)[build_df$X] %in% levels(base_df$X)[base_df$X],colnames(build_df) %in% colnames(base_df)]

wp_df = data.frame(County = base_df[,"X"], ACSWorkProds = rowSums(base_df[,2:ncol(base_df)]))
wp_dfb = data.frame(County = build_df[,"X"], ModWorkProds = round(rowSums(build_df[,2:ncol(build_df)])/BUILD_SAMPLE_RATE))
wp_df$ModWorkProds = wp_dfb$ModWorkProds[match(levels(wp_df$County)[wp_df$County], levels(wp_dfb$County)[wp_dfb$County])]

wp_df = wp_df[!wp_df$County == "Total",]
wp_df$County = levels(wp_df$County)[wp_df$County]

colnames(wp_df) = c('County', 'ACS', 'ASim')

eval_expr <- paste("tworktourprod <- kable(wp_df, format = 'html', digits = 2, row.names = F, align = 'r', format.args = list(big.mark = ',')) %>%
  kable_styling('striped', font_size = 10, full_width=F, position='center') ", sep = "")
eval(parse(text = eval_expr))
tworktourprod

```

Chart Column 1
--------------------------------------------

### Tour Attraction Comparison {data-height=300}
```{r aWorkTourAttrs}

base_df <- base_data[[which(base_csv_names=="countyFlowsCensus")]]

build_pos <- which(build_csv_names=="countyFlows")
build_df <- build_data[[build_pos]]

build_df = build_df[levels(build_df$X)[build_df$X] %in% levels(base_df$X)[base_df$X],colnames(build_df) %in% colnames(base_df)]

wp_df = data.frame(County = base_df[,"X"], ACSWorkAttr = colSums(base_df[,2:ncol(base_df)]))
wp_dfb = data.frame(County = build_df[,"X"], ModWorkAttr = round(colSums(build_df[,2:ncol(build_df)])/BUILD_SAMPLE_RATE))
wp_df$ModWorkAttrs = wp_dfb$ModWorkAttr[match(levels(wp_df$County)[wp_df$County], levels(wp_dfb$County)[wp_dfb$County])]

wp_df = wp_df[!wp_df$County == "Total",]
wp_df$County = levels(wp_df$County)[wp_df$County]

colnames(wp_df) = c("xvar", "yvar1", "yvar2")

p <- plotly_bar_plotter(data = wp_df, xlabel = "County", ylabel = "Tours", ynames = c(AO_CENSUS_LONG, BUILD_SCENARIO_NAME), percent = F, height = 275, tickangle = -320, bottom_offset = 25)
p

```

### {data-height=280}

```{r aWorkTourAttrTable}
base_df <- base_data[[which(base_csv_names=="countyFlowsCensus")]]

build_pos <- which(build_csv_names=="countyFlows")
build_df <- build_data[[build_pos]]

build_df = build_df[levels(build_df$X)[build_df$X] %in% levels(base_df$X)[base_df$X],colnames(build_df) %in% colnames(base_df)]

wp_df = data.frame(County = base_df[,"X"], ACSWorkAttr = colSums(base_df[,2:ncol(base_df)]))
wp_dfb = data.frame(County = build_df[,"X"], ModWorkAttr = round(colSums(build_df[,2:ncol(build_df)])/BUILD_SAMPLE_RATE))
wp_df$ModWorkAttrs = wp_dfb$ModWorkAttr[match(levels(wp_df$County)[wp_df$County], levels(wp_dfb$County)[wp_dfb$County])]

wp_df = wp_df[!wp_df$County == "Total",]
wp_df$County = levels(wp_df$County)[wp_df$County]

colnames(wp_df) = c('County', 'ACS', 'ASim')

eval_expr <- paste("tworktourattr <- kable(wp_df, format = 'html', digits = 2, row.names = F, align = 'r', format.args = list(big.mark = ',')) %>%
  kable_styling('striped', font_size = 10, full_width=F, position='center') ", sep = "")
eval(parse(text = eval_expr))
tworktourattr

```



Zero Auto Households {data-navmenu="Long Term"}
============================================

Description {.sidebar data-width=175}
--------------------------------------------

********

**Census vs Model comparison at Census Tract level**

Compares number of zero auto households.

Census Data is from 2017 five year ACS.

Only for build scenario.

Summary
--------------------------------------------

### Zero Auto Households Census vs Model
```{r zero_auto_hh}

# BEWARE! shp data names are shortend by writeOGR in the script that creates the ct_zero_auto_shp file
#  Names in that script won't match names shown here.
#  For example, ct_zero_auto_shp@data$Diff_ZeroAuto ->  ct_zero_auto_shp@data$Dff_ZrA
labels <- sprintf(
  "%s
%s %.2f %s
%s", ct_zero_auto_shp@data$TRACTCE, ct_zero_auto_shp@data$txtCmm2, ct_zero_auto_shp@data$Dff_ZrA, "%", ct_zero_auto_shp@data$txtCmm1) %>% lapply(htmltools::HTML) bins <- c(-Inf, -100, -75, -50, -25, -5, 5, 25, 50, 75, 100, Inf) pal <- colorBin("PiYG", domain = ct_zero_auto_shp@data$Dff_ZrA, na.color="transparent", bins = bins) m <- leaflet(data = ct_zero_auto_shp)%>% addTiles() %>% addProviderTiles(providers$OpenStreetMap, group = "Background Map") %>% addLayersControl( overlayGroups = "Background Map", options = layersControlOptions(collapsed = FALSE) ) %>% addPolygons(group='ZeroCarDiff', fillColor = ~pal(Dff_ZrA), weight = 0.2, opacity = 1, color = "gray", stroke=T, dashArray = "5, 1", fillOpacity = 0.7, highlight = highlightOptions( weight = 1, color = "blue", dashArray = "", fillOpacity = 0.7, bringToFront = TRUE), label = labels, labelOptions = labelOptions( style = list("font-weight" = "normal", padding = "3px 8px"), textsize = "15px", direction = "auto")) %>% addLegend(pal = pal, values = ~density, opacity = 0.7, title = "Estimated(%) - Observed(%) Bins", position = "bottomright") m ``` Tour Summaries{data-navmenu="Tour Level"} ============================================ Description {.sidebar data-width=225} -------------------------------------------- This page summarizes day-pattern and tour generation model results. **Daily Activity Pattern** Results of Coordinated Daily Activity Pattern (CDAP) model, summarized for each person. _M_ : One or more mandatory tours _N_ : No mandatory tours but one or more non-mandatory tours _H_ : No tours (either home all day or out of area) **Percentage of Households with Joint Tour** Also the result of the CDAP model, summarized for each household. **Mandatory Tour Frequency** Result of the mandatory tour frequency model, summarized for each person with a daily activity pattern type _M_ **Tour rate by person type** Summary of tours per person resulting from all tour generation models. Joint tours are counted for each participant. **Individual non-mandatory tour frequency** Results of individual non-mandatory tour frequency model, summarized for each person with a daily activity pattern type _M_ or _N_. Chart Column 1 {data-width=160} -------------------------------------------- ### Daily Activity Pattern{data-height=500} ```{r Hist_DAP} base_df <- base_data[[which(base_csv_names=="dapSummary_vis")]] base_df$PERNAME <- person_type_df$name_char[match(base_df$PERTYPE, person_type_df$code)] base_df$PERNAME <- factor(base_df$PERNAME, levels = person_type_char) base_df$DAP <- factor(base_df$DAP, levels = dap_types) build_df <- build_data[[which(build_csv_names=="dapSummary_vis")]] build_df$PERNAME <- person_type_df$name_char[match(build_df$PERTYPE, person_type_df$code)] build_df$PERNAME <- factor(build_df$PERNAME, levels = person_type_char) build_df$DAP <- factor(build_df$DAP, levels = dap_types) base_df$grp <- BASE_SCENARIO_NAME build_df$grp <- BUILD_SCENARIO_NAME colnames(build_df) <- colnames(base_df) sd.pertype <- get_standardDF(data_df1=base_df, data_df2=build_df, x="DAP", y = c("freq"), grp = "PERNAME", shared = T) p <- plotly_bar_plotter(data = sd.pertype, height = 250, xlabel = "DAP", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T) bscols(widths=c(3,9), list( filter_select("pertype_dap", "Select Person Type", sd.pertype, ~grp_var,multiple=F)), p ) ``` ### Percentage of Households with a Joint Tour{data-height=300} ```{r Hist_Presence_Joint} base_pos <- which(base_csv_names=="hhsizeJoint") base_df <- base_data[[base_pos]] base_df <- base_df %>% group_by(HHSIZE) %>% mutate(percent = prop.table(freq)) %>% filter(JOINT==1) %>% ungroup() build_pos <- which(build_csv_names=="hhsizeJoint") build_df <- build_data[[build_pos]] build_df <- build_df %>% group_by(HHSIZE) %>% mutate(percent = prop.table(freq)) %>% filter(JOINT==1) %>% ungroup() colnames(build_df) <- colnames(base_df) std_DF <- get_standardDF(data_df1 = base_df, data_df2 = build_df, x = "HHSIZE", y = c("percent")) p <- plotly_bar_plotter(data = std_DF, xlabel = "HH Size", ylabel = "Percent of Households", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = F, tickformat = ".0%", hoverformat = ".1%") p ``` ### Mandatory Tour Frequency{data-height=500} ```{r Hist_MTF} base_pos <- which(base_csv_names=="mtfSummary_vis") base_df <- base_data[[base_pos]] base_df$PERNAME <- person_type_df$name_char[match(base_df$PERTYPE, person_type_df$code)] base_df$PERNAME <- factor(base_df$PERNAME, levels = person_type_char) base_df$mtf_name <- mtf_df$name[match(base_df$MTF, mtf_df$code)] base_df$mtf_name <- factor(base_df$mtf_name, levels = mtf_names) build_pos <- which(build_csv_names=="mtfSummary_vis") build_df <- build_data[[build_pos]] build_df$PERNAME <- person_type_df$name_char[match(build_df$PERTYPE, person_type_df$code)] build_df$PERNAME <- factor(build_df$PERNAME, levels = person_type_char) build_df$mtf_name <- mtf_df$name[match(build_df$MTF, mtf_df$code)] build_df$mtf_name <- factor(build_df$mtf_name, levels = mtf_names) colnames(build_df) <- colnames(base_df) sd.pertype <- get_standardDF(data_df1=base_df, data_df2=build_df, x="mtf_name", y = c("freq"), grp = "PERNAME", shared = T) p <- plotly_bar_plotter(data = sd.pertype, height = 250, xlabel = "MTF Choice", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, tickangle = -30, bottom_offset = 50) bscols(widths=c(3,9), list( filter_select("pertype_mtf", "Select Person Type", sd.pertype, ~grp_var,multiple=F)), p ) ``` Chart Column 1 {data-width=150} -------------------------------------------- ### Total Tour Rate (only active Persons) ```{r Hist_totaltours} base_df <- base_data[[which(base_csv_names=="total_tours_by_pertype_vis")]] base_df$PERNAME <- person_type_df$name_char[match(base_df$PERTYPE, person_type_df$code)] base_df$PERNAME <- factor(base_df$PERNAME, levels = person_type_char) base_df1 <- base_data[[which(base_csv_names=="activePertypeDistbn")]] base_df$persons <- base_df1$freq[match(base_df$PERTYPE, base_df1$PERTYPE)] base_df$tourrate <- round(base_df$freq/base_df$persons,2) build_df <- build_data[[which(build_csv_names=="total_tours_by_pertype_vis")]] build_df$PERNAME <- person_type_df$name_char[match(build_df$PERTYPE, person_type_df$code)] build_df$PERNAME <- factor(build_df$PERNAME, levels = person_type_char) build_df1 <- build_data[[which(build_csv_names=="activePertypeDistbn")]] build_df$persons <- build_df1$freq[match(build_df$PERTYPE, build_df1$PERTYPE)] build_df$tourrate <- round(build_df$freq/build_df$persons,2) colnames(build_df) <- colnames(base_df) std_DF <- get_standardDF(data_df1 = base_df, data_df2 = build_df, x = "PERNAME", y = c("tourrate")) p <- plotly_bar_plotter(data = std_DF, xlabel = "Person Type", ylabel = "Tour Rate", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = F, height = 340, tickangle = -30, bottom_offset = 50) p ``` ### Persons by Individual Non-Mandatory Tours ```{r Hist_INM} base_df <- base_data[[which(base_csv_names=="inmSummary_vis")]] base_df$PERNAME <- person_type_df$name_char[match(base_df$PERTYPE, person_type_df$code)] base_df$PERNAME <- factor(base_df$PERNAME, levels = person_type_char) build_df <- build_data[[which(build_csv_names=="inmSummary_vis")]] build_df$PERNAME <- person_type_df$name_char[match(build_df$PERTYPE, person_type_df$code)] build_df$PERNAME <- factor(build_df$PERNAME, levels = person_type_char) colnames(build_df) <- colnames(base_df) sd.pertype <- get_standardDF(data_df1=base_df, data_df2=build_df, x="nmtours", y = c("freq"), grp = "PERNAME", shared = T) #p <- plotly_bar_plotter(data = sd.pertype, height = 340, xlabel = "Number of Tours", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, #BUILD_SCENARIO_NAME), percent = T, tickvals = c(seq(0,2), "3pl"), ticktext = c("0", "1", "2", "3pl")) p <- plotly_bar_plotter(data = sd.pertype, height = 340, xlabel = "Number of Tours", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T) bscols(widths=c(3,9), list( filter_select("pertype_mtf", "Select Person Type", sd.pertype, ~grp_var,multiple=F)), p ) ``` Joint Tours{data-navmenu="Tour Level"} ============================================ Description {.sidebar data-width=225} -------------------------------------------- ******** This page tabulates the results of the Joint Tour Frequency and Composition Model and the Joint Tour Person Participation Model. **Joint Tour Frequency** The frequency of households by number and purpose of joint tours. **Joint Tour Composition** The frequency of tours by composition (Adults only, Children only, Adults + Children). **Joint Tour Party Size** The frequency of joint tours by the number of household members participating in the tour. **Joint Tours by HH Size** The frequency of households by household size and the number of joint tours per household. **Joint Tours by HH Size** _Tour Level_ Distribution of joint tours by party size for each composition type. Chart Column 1 {data-width=150} -------------------------------------------- ### Joint Tour Frequency{data-height=675} ```{r jtf} base_df <- base_data[[which(base_csv_names=="jtf")]] build_df <- build_data[[which(build_csv_names=="jtf")]] # remove no joint tours option base_df <- base_df[-1,] build_df <- build_df[-1,] colnames(build_df) <- colnames(base_df) std_DF <- get_standardDF(data_df1 = base_df, data_df2 = build_df, x = "alt_name", y = c("freq")) std_DF$xvar <- factor(std_DF$xvar, levels = jtf_alternatives) p <- plotly_bar_plotter(data = std_DF, xlabel = "Joint Tour Combination", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, height = 500, bottom_offset = 275, tickangle = 300) p ``` ### Joint Tour Composition ```{r jtf_comp} base_df <- base_data[[which(base_csv_names=="jointComp")]] names(base_df)[names(base_df)=="tour_composition"] <- "COMPOSITION" build_df <- build_data[[which(build_csv_names=="jointComp")]] colnames(build_df) <- colnames(base_df) p1 <- plotly_pie_chart(data = base_df, label_var = "COMPOSITION", value_var = "freq", height = 250, title = BASE_SCENARIO_NAME, top_offset = 50) p2 <- plotly_pie_chart(data = build_df, label_var = "COMPOSITION", value_var = "freq", height = 250, title = BUILD_SCENARIO_NAME, top_offset = 50) bscols(widths=c(6,6), p1, p2 ) ``` Chart Column 1 {data-width=150} -------------------------------------------- ### Joint Tours By Number of Household Members ```{r jtf_partysize} base_df <- base_data[[which(base_csv_names=="jointPartySize")]] build_df <- build_data[[which(build_csv_names=="jointPartySize")]] colnames(build_df) <- colnames(base_df) build_df$freq[build_df$NUMBER_HH==5] <- sum(build_df$freq[build_df$NUMBER_HH>=5]) build_df <- build_df[build_df$NUMBER_HH<=5, ] std_DF <- get_standardDF(data_df1 = base_df, data_df2 = build_df, x = "NUMBER_HH", y = c("freq")) p <- plotly_bar_plotter(data = std_DF, xlabel = "Joint Party Size", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, height = 200) p ``` ### Joint Tours by Household Size ```{r jtf_byhhsize} base_pos <- which(base_csv_names=="jointToursHHSize") base_df <- base_data[[base_pos]] build_pos <- which(build_csv_names=="jointToursHHSize") build_df <- build_data[[build_pos]] colnames(build_df) <- colnames(base_df) sd.pertype <- get_standardDF(data_df1=base_df, data_df2=build_df, x="jointTours", y = c("freq"), grp = "hhsize", shared = T) p <- plotly_bar_plotter(data = sd.pertype, height = 225, xlabel = "Number of Joint Tours", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T) bscols(widths=c(3,9), list( filter_select("jtf_hhsize", "Select HH Size Group", sd.pertype, ~grp_var,multiple=F)), p ) ``` ### Party Size Distribution by Joint Tour Composition ```{r jtf_comppartysize} base_df <- base_data[[which(base_csv_names=="jointCompPartySize")]] build_df <- build_data[[which(build_csv_names=="jointCompPartySize")]] colnames(build_df) <- colnames(base_df) sd.pertype <- get_standardDF(data_df1=base_df, data_df2=build_df, x="partysize", y = c("freq"), grp = "comp", shared = T) p <- plotly_bar_plotter(data = sd.pertype, height = 225, xlabel = "Joint Party Size", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T) bscols(widths=c(3,9), list( filter_select("jtf_comp", "Select Party Composition", sd.pertype, ~grp_var,multiple=F)), p ) ``` Destination{data-navmenu="Tour Level"} ============================================ Description {.sidebar data-width=225} -------------------------------------------- ******** **Non-Mandatory Tour Length Distribution** Results of non-mandatory tour destination choice models. Distribution of tours by distance between tour origin and destination for each non-mandatory tour purpose. Chart Column 1 {data-width=100} -------------------------------------------- ### Non-Mandatory Tour Length Distribution{data-height=350} ```{r nm_tlfd} base_df <- base_data[[which(base_csv_names=="tourDistProfile_vis")]] build_df <- build_data[[which(build_csv_names=="tourDistProfile_vis")]] colnames(build_df) <- colnames(base_df) # change purpose names to standard format base_df$PURPOSE <- as.character(base_df$PURPOSE) build_df$PURPOSE <- as.character(build_df$PURPOSE) base_df$PURPOSE <- purpose_type_df$name[match(base_df$PURPOSE, purpose_type_df$code)] build_df$PURPOSE <- purpose_type_df$name[match(build_df$PURPOSE, purpose_type_df$code)] sd.purpose <- get_sharedData(data_df1 = base_df, data_df2 = build_df, run1_name = BASE_SCENARIO_NAME, run2_name = BUILD_SCENARIO_NAME, x = "distbin", y = c("freq"), grp = "PURPOSE") p1 <- plotly_density_plotter(sd.purpose, index = "one", xlabel = "Miles", percent = T, tickvals = seq(2,41), ticktext = c(seq(1,40), "40pl")) bscols(widths=c(2,10), filter_select("Tour Purpose", "Select Tour Purpose", sd.purpose, ~grp_var,multiple=F), p1 ) ``` ### Average Non-Mandatory Tour Lengths (Miles){data-height=250} ```{r Table1_nonMandTripLength} base_df <- base_data[[which(base_csv_names=="nonMandTripLengths")]] build_df <- build_data[[which(build_csv_names=="nonMandTourLengths")]] df <- data.frame(base_df, build_df[,-1]) colnames(df) <- c("Purpose", BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME) df$Purpose <- purpose_type_df$name[match(df$Purpose, purpose_type_df$code)] t1 <- kable(df, format = "html", digits = 2, row.names = F, align = 'c', format.args = list(big.mark = ',')) %>% kable_styling("striped", full_width = F) t1 ``` TOD {data-navmenu="Tour Level"} ============================================ Description {.sidebar data-width=200} -------------------------------------------- ******** **Tour Departure Arrival & Duration** Tour Time-of-day Choice Model results. Each tour is assigned a time period of departure (time leaving home or work) and arrival (time arriving back at home or work). The entire day is divided into 18 one-hour bins (the first bin includes 3:00 AM to 6:00 AM and the last bin includes 11:00 PM to 3:00 AM). Tour duration is calculated as a function of departure and arrival period. It includes travel time and time spent at the primary destination and all intermediate stops. Results are shown for tours, filtered by tour purpose. ******** Chart Column 1 {.tabset} -------------------------------------------- ### Tour Departure-Arrival Profile ```{r tour_tod} base_df <- base_data[[which(base_csv_names=="todProfile_vis")]] base_df$tod_bin <- tod_df$bin[match(base_df$id, tod_df$id)] base_df$dur_bin <- dur_df$bin[match(base_df$id, dur_df$id)] build_df <- build_data[[which(build_csv_names=="todProfile_vis")]] build_df$tod_bin <- tod_df$bin[match(build_df$id, tod_df$id)] build_df$dur_bin <- dur_df$bin[match(build_df$id, dur_df$id)] colnames(build_df) <- colnames(base_df) # change purpose names to standard format base_df$purpose <- as.character(base_df$purpose) build_df$purpose <- as.character(build_df$purpose) base_df$purpose <- purpose_type_df$name[match(base_df$purpose, purpose_type_df$code)] build_df$purpose <- purpose_type_df$name[match(build_df$purpose, purpose_type_df$code)] sd.purpose <- get_sharedData(data_df1 = base_df, data_df2 = build_df, run1_name = BASE_SCENARIO_NAME, run2_name = BUILD_SCENARIO_NAME, x = "id", y = c("freq_dep", "freq_arr", "freq_dur"), grp = "purpose") p1 <- plotly_density_plotter(sd.purpose, index = "one", xlabel = "Tour Departure", percent = T, left_offset = 25, tickvals = seq(1,48), ticktext = todBins, bottom_offset = 150, tickangle = 315, height = 275) p2 <- plotly_density_plotter(sd.purpose, index = "two", xlabel = "Tour Arrival", percent = T, left_offset = 25, tickvals = seq(1,48), ticktext = todBins, bottom_offset = 150, tickangle = 315, height = 275) p3 <- plotly_density_plotter(sd.purpose, index = "three", xlabel = "Tour Duration", percent = T, left_offset = 25, tickvals = seq(1,48), ticktext = durBins, bottom_offset = 50, tickangle = 315, height = 225) bscols(widths=c(2,10), filter_select("Tour Purpose", "Select Tour Purpose", sd.purpose, ~grp_var,multiple=F), list(p1, p2, p3) ) ``` ### Tour Aggregate Departure-Arrival Profile ```{r tour_tod_agg} base_df <- base_data[[which(base_csv_names=="todProfile_vis")]] base_df$tod_agg <- cut(base_df$id, breaks = timePeriodBreaks, labels = timePeriods, right = FALSE) base_df$tod_agg <- factor(base_df$tod_agg, levels = timePeriodOrder) base_df <- base_df %>% dplyr::group_by(purpose, tod_agg) %>% dplyr::summarise(freq_dep = sum(freq_dep), freq_arr = sum(freq_arr), freq_dur = sum(freq_dur)) %>% dplyr::ungroup() base_df = base_df %>% arrange(match(tod_agg, timePeriodOrder)) build_df <- build_data[[which(build_csv_names=="todProfile_vis")]] build_df$tod_agg <- cut(build_df$id, breaks = timePeriodBreaks, labels = timePeriods, right = FALSE) build_df$tod_agg <- factor(build_df$tod_agg, levels = timePeriodOrder) build_df <- build_df %>% dplyr::group_by(purpose, tod_agg) %>% dplyr::summarise(freq_dep = sum(freq_dep), freq_arr = sum(freq_arr), freq_dur = sum(freq_dur)) %>% dplyr::ungroup() build_df = build_df %>% arrange(match(tod_agg, timePeriodOrder)) colnames(build_df) <- colnames(base_df) # change purpose names to standard format base_df$purpose <- as.character(base_df$purpose) build_df$purpose <- as.character(build_df$purpose) base_df$purpose <- purpose_type_df$name[match(base_df$purpose, purpose_type_df$code)] build_df$purpose <- purpose_type_df$name[match(build_df$purpose, purpose_type_df$code)] sd.purpose <- get_standardDF(data_df1=base_df, data_df2=build_df, x="tod_agg", y = c("freq_dep", "freq_arr", "freq_dur"), grp = "purpose", shared = T) p1 <- plotly_bar_plotter(data = sd.purpose, height = 350, xlabel = "Tour Departure", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T) p2 <- plotly_bar_plotter(data = sd.purpose, height = 350, xlabel = "Tour Arrival", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, index = 2) bscols(widths=c(2,10), filter_select("Tour Purpose", "Select Tour Purpose", sd.purpose, ~grp_var,multiple=F), list(p1, p2) ) ``` Tour Mode{data-navmenu="Tour Level"} ============================================ Chart Column 1{data-width=150} -------------------------------------------- ### Tour Mode Choice ```{r tourMode} # [3/31/2020] DH if(BUILD_SCENARIO_NAME == "CMAP_OBS") { # if running HTS vs OBS mode comparison base_df <- base_data[[which(base_csv_names=="tmodeProfile_vis_HTS")]] build_df <- build_data[[which(build_csv_names=="tmodeProfile_vis_calib")]] } else { base_df <- base_data[[which(base_csv_names=="tmodeProfile_vis_calib")]] build_df <- build_data[[which(build_csv_names=="tmodeProfile_vis")]] } build_df$purpose <- as.character(build_df$purpose) build_df$purpose <- purpose_type_df$name[match(build_df$purpose, purpose_type_df$code)] colnames(build_df) <- colnames(base_df) base_df$purpose <- as.character(base_df$purpose) base_df$purpose <- purpose_type_df$name[match(base_df$purpose, purpose_type_df$code)] sd.pertype <- get_standardDF(data_df1=base_df, data_df2=build_df, x="id", y = c("freq_as0", "freq_as1", "freq_as2", "freq_all"), grp = "purpose", shared = T) p1 <- plotly_bar_plotter(data = sd.pertype, height = 375, xlabel = "Tour Mode [Zero Auto]", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, tickvals = seq(1,length(tourMode)), ticktext = tourMode, bottom_offset = 55, tickangle = 300) p2 <- plotly_bar_plotter(data = sd.pertype, height = 375, xlabel = "Tour Mode [Autos < Workers]", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, tickvals = seq(1,length(tourMode)), ticktext = tourMode, index = 2, bottom_offset = 55, tickangle = 300) p3 <- plotly_bar_plotter(data = sd.pertype, height = 375, xlabel = "Tour Mode [Autos >= Workers]", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, tickvals = seq(1,length(tourMode)), ticktext = tourMode, index = 3, bottom_offset = 55, tickangle = 300) p4 <- plotly_bar_plotter(data = sd.pertype, height = 375, xlabel = "Tour Mode [Total]", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, tickvals = seq(1,length(tourMode)), ticktext = tourMode, index = 4, bottom_offset = 55, tickangle = 300) filter_select("tourMode", "Select Tour Purpose", sd.pertype, ~grp_var,multiple=F) ``` ******** **Tour Mode Choice** Results of Tour Mode Choice Models, which selects a primary mode for each tour. Distribution of tours by tour mode and the ratio of autos to drivers in the household. Chart Column 2 {data-width=400} -------------------------------------------- ### ```{r tourMode2} bscols(widths=c(12), list(p1,p2) ) ``` Chart Column 3 {data-width=400} -------------------------------------------- ### ```{r tourMode3} bscols(widths=c(12), list(p3,p4) ) ``` Stop Frequency {data-navmenu="Trip Level"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Stop Frequency** Results of the Intermediate Stop Frequency Model, which predicts the number of intermediate stops on each tour by tour direction (outbound versus inbound). The summary shows percent of tours by number of stops on the tour and tour direction. **Stop Purpose** Results of the Intermediate Stop Purpose Model, which is currently implemented as a Monte Carlo choice according to probability distributions generated from survey data. The summary shows the percent of intermediate stops by stop purpose and tour purpose. Chart Column 1 {data-width=200} -------------------------------------------- ### Stop Frequency - Directional ```{r stopfreq_dir} base_df <- base_data[[which(base_csv_names=="stopfreqDir_vis")]] build_df <- build_data[[which(build_csv_names=="stopfreqDir_vis")]] colnames(build_df) <- colnames(base_df) # change purpose names to standard format base_df$purpose <- as.character(base_df$purpose) build_df$purpose <- as.character(build_df$purpose) base_df$purpose <- purpose_type_df$name[match(base_df$purpose, purpose_type_df$code)] build_df$purpose <- purpose_type_df$name[match(build_df$purpose, purpose_type_df$code)] sd.pertype1 <- get_standardDF(data_df1=base_df, data_df2=build_df, x="nstops", y = c("freq_out", "freq_inb"), grp = "purpose", shared = T) p1 <- plotly_bar_plotter(data = sd.pertype1, height = 325, xlabel = "Number of Stops - Outbound", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, tickvals = seq(1,4), ticktext = c("0", "1", "2", "3pl")) p2 <- plotly_bar_plotter(data = sd.pertype1, height = 325, xlabel = "Number of Stops - Inbound", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, tickvals = seq(1,4), ticktext = c("0", "1", "2", "3pl"), index = 2) bscols(widths=c(12), list( filter_select("stopfreq_dir", "Select Tour Purpose", sd.pertype1, ~grp_var,multiple=F), p1, p2) ) ``` Chart Column 1 {data-width=300} -------------------------------------------- ### Stop Frequency - Total{data-height=250} ```{r stopfreq_total} base_df <- base_data[[which(base_csv_names=="stopfreq_total_vis")]] build_df <- build_data[[which(build_csv_names=="stopfreq_total_vis")]] colnames(build_df) <- colnames(base_df) # change purpose names to standard format base_df$purpose <- as.character(base_df$purpose) build_df$purpose <- as.character(build_df$purpose) base_df$purpose <- purpose_type_df$name[match(base_df$purpose, purpose_type_df$code)] build_df$purpose <- purpose_type_df$name[match(build_df$purpose, purpose_type_df$code)] sd.pertype2 <- get_standardDF(data_df1=base_df, data_df2=build_df, x="nstops", y = c("freq"), grp = "purpose", shared = T) p1 <- plotly_bar_plotter(data = sd.pertype2, height = 350, xlabel = "Number of Stops", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, tickvals = seq(1,7), ticktext = c("0", "1", "2", "3", "4", "5", "6pl")) bscols(widths=c(3,9), list( filter_select("stopfreq_total", "Select Tour Purpose", sd.pertype2, ~grp_var,multiple=F)), p1 ) ``` ### Stop Purpose by Tour Purpose{data-height=250} ```{r stoppurp_tourpurp} base_df <- base_data[[which(base_csv_names=="stoppurpose_tourpurpose_vis")]] build_df <- build_data[[which(build_csv_names=="stoppurpose_tourpurpose_vis")]] colnames(build_df) <- colnames(base_df) # change purpose names to standard format base_df$purpose <- as.character(base_df$purpose) build_df$purpose <- as.character(build_df$purpose) base_df$purpose <- purpose_type_df$name[match(base_df$purpose, purpose_type_df$code)] build_df$purpose <- purpose_type_df$name[match(build_df$purpose, purpose_type_df$code)] sd.pertype3 <- get_standardDF(data_df1=base_df, data_df2=build_df, x="stop_purp", y = c("freq"), grp = "purpose", shared = T) p1 <- plotly_bar_plotter(data = sd.pertype3, height = 350, xlabel = "Stop Purpose", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, tickvals = seq(1,9), ticktext = stopPurposes[1:9]) bscols(widths=c(3,9), list( filter_select("stoppurp_tourpurp", "Select Tour Purpose", sd.pertype3, ~grp_var,multiple=F)), p1 ) ``` Location{data-navmenu="Trip Level"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Stop Location** Results of the Intermediate Stop Location Choice Model, which predicts the location of each intermediate stop. The summary shows the distribution of intermediate stops by out of direction distance and tour purpose. Out of direction distance is defined as the extra distance to the destination as a result of traveling through the stop location. For stops in the outbound direction, it is based on the distance between the last known location (the tour origin or previous outbound stop) and the tour primary destination. For stops in the inbound direction, it is based on the distance between the last known location (the tour primary destination or previous inbound stop) and the tour origin. Chart Column 1 {data-width=800} -------------------------------------------- ### Stop Location - Out of Direction Distance{data-height=350} ```{r stopDC} base_df <- base_data[[which(base_csv_names=="stopDC_vis")]] build_df <- build_data[[which(build_csv_names=="stopDC_vis")]] colnames(build_df) <- colnames(base_df) # change purpose names to standard format base_df$PURPOSE <- as.character(base_df$PURPOSE) build_df$PURPOSE <- as.character(build_df$PURPOSE) base_df$PURPOSE <- purpose_type_df$name[match(base_df$PURPOSE, purpose_type_df$code)] build_df$PURPOSE <- purpose_type_df$name[match(build_df$PURPOSE, purpose_type_df$code)] sd.purpose <- get_sharedData(data_df1 = base_df, data_df2 = build_df, run1_name = BASE_SCENARIO_NAME, run2_name = BUILD_SCENARIO_NAME, x = "distbin", y = c("freq"), grp = "PURPOSE") p1 <- plotly_density_plotter(sd.purpose, index = "one", xlabel = "Out of Direction Distance (Miles)", percent = T, left_offset = 25, tickvals = seq(1,42), ticktext = outDirDist, height = 600, tickangle = 300, bottom_offset = 50) bscols(widths=c(12), list( filter_select("stopDC", "Select Tour Purpose", sd.purpose, ~grp_var,multiple=F), p1) ) ``` Chart Column 1 {data-width=300} -------------------------------------------- ### Average Out of Direction Distance (Miles){data-height=250} ```{r Table1_outOfDir} base_df <- base_data[[which(base_csv_names=="avgStopOutofDirectionDist_vis")]] build_df <- build_data[[which(build_csv_names=="avgStopOutofDirectionDist_vis")]] df <- data.frame(base_df, build_df[,-1]) colnames(df) <- c("Tour_Purpose", BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME) df$Tour_Purpose <- purpose_type_df$name[match(df$Tour_Purpose, purpose_type_df$code)] # #t1 <- kable(df, format = "html", digits = 2, row.names = F, align = 'c', format.args = list(big.mark = ',')) %>% # kable_styling("striped", full_width = F) df[,2:3] = round(100 * df[,2:3]) / 100 t1 <- htmlTable(df, align = "c|r|r", rnames = F, col.columns = c(rep("#E6E6F0", 1), rep("none", ncol(df) - 1)), caption = "_______________________________________________________") t1 ``` TOD{data-navmenu="Trip Level"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Stop Departure** Results of the Stop Departure Time Choice Model. The departure time of each stop on the tour is currently implemented as a Monte Carlo choice of time period from distributions generated from survey data. The entire day is divided into 18 one-hour bins (The first bin includes 3:00 AM to 6:00 AM and the last bin includes 11:00 PM to 3:00 AM). **Trip Departure** Summarizes all trips by departure time period, including trips to and from intermediate stops and the tour primary destination. Chart Column 1 {.tabset} -------------------------------------------- ### Stop & Trip Departure{data-height=650} ```{r stopDep} base_df <- base_data[[which(base_csv_names=="stopTripDep_vis")]] build_df <- build_data[[which(build_csv_names=="stopTripDep_vis")]] colnames(base_df) <- c("timebin", "purpose", "freq_stop", "freq_trip") colnames(build_df) <- colnames(base_df) # change purpose names to standard format base_df$purpose <- as.character(base_df$purpose) build_df$purpose <- as.character(build_df$purpose) base_df$purpose <- purpose_type_df$name[match(base_df$purpose, purpose_type_df$code)] build_df$purpose <- purpose_type_df$name[match(build_df$purpose, purpose_type_df$code)] sd.purpose <- get_sharedData(data_df1 = base_df, data_df2 = build_df, run1_name = BASE_SCENARIO_NAME, run2_name = BUILD_SCENARIO_NAME, x = "timebin", y = c("freq_stop", "freq_trip"), grp = "purpose") p1 <- plotly_density_plotter(sd.purpose, index = "one", xlabel = "Stop Departure", percent = T, left_offset = 25, tickvals = seq(1,48), ticktext = todBins, bottom_offset = 150, tickangle = 315, height = 400) p2 <- plotly_density_plotter(sd.purpose, index = "two", xlabel = "Trip Departure", percent = T, left_offset = 25, tickvals = seq(1,48), ticktext = todBins, bottom_offset = 150, tickangle = 315, height = 400) #p3 <- datatable(sd.purpose$data()) bscols(widths=c(2,10), filter_select("Tour Purpose", "Select Tour Purpose", sd.purpose, ~grp_var,multiple=F), list(p1, p2) ) ``` ### Aggregate Stop & Trip Departure ```{r trip_tod_agg} base_df <- base_data[[which(base_csv_names=="stopTripDep_vis")]] colnames(base_df) <- c("id","purpose","freq_stop","freq_trip") base_df$tod_agg <- cut(base_df$id, breaks = timePeriodBreaks, labels = timePeriods, right = FALSE) base_df$tod_agg <- factor(base_df$tod_agg, levels = timePeriodOrder) base_df <- base_df %>% group_by(purpose, tod_agg) %>% dplyr::summarise(freq_stop = sum(freq_stop), freq_trip = sum(freq_trip)) %>% ungroup() build_df <- build_data[[which(build_csv_names=="stopTripDep_vis")]] colnames(build_df) <- c("id","purpose","freq_stop","freq_trip") build_df$tod_agg <- cut(build_df$id, breaks = timePeriodBreaks, labels = timePeriods, right = FALSE) build_df$tod_agg <- factor(build_df$tod_agg, levels = timePeriodOrder) build_df <- build_df %>% group_by(purpose, tod_agg) %>% dplyr::summarise(freq_stop = sum(freq_stop), freq_trip = sum(freq_trip)) %>% ungroup() colnames(build_df) <- colnames(base_df) # change purpose names to standard format base_df$purpose <- as.character(base_df$purpose) build_df$purpose <- as.character(build_df$purpose) base_df$purpose <- purpose_type_df$name[match(base_df$purpose, purpose_type_df$code)] build_df$purpose <- purpose_type_df$name[match(build_df$purpose, purpose_type_df$code)] sd.purpose <- get_standardDF(data_df1=base_df, data_df2=build_df, x="tod_agg", y = c("freq_stop", "freq_trip"), grp = "purpose", shared = T) p1 <- plotly_bar_plotter(data = sd.purpose, height = 350, xlabel = "Stop Departure", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T) p2 <- plotly_bar_plotter(data = sd.purpose, height = 350, xlabel = "Trip Departure", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, index = 2) bscols(widths=c(2,10), filter_select("Tour Purpose", "Select Tour Purpose", sd.purpose, ~grp_var,multiple=F), list(p1, p2) ) ``` Trip Mode{data-navmenu="Trip Level"} ============================================ Chart Column 1 {data-width=125} -------------------------------------------- ### {data-height=200} ***Trip Mode Choice*** The results of the Trip Mode Choice Model, which predicts the mode of each trip on the tour. Distribution of trips by trip mode and tour mode, which constrains the availability of each trip mode and influences the utility of each available trip mode. ### Trip Mode Choice ```{r tripMode} if(BUILD_SCENARIO_NAME == 'CMAP_OBS') { base_df <- base_data[[which(base_csv_names=="tripModeProfile_vis_HTS")]] build_df <- build_data[[which(build_csv_names=="tripModeProfile_vis_calib")]] } else { build_df <- build_data[[which(build_csv_names=="tripModeProfile_vis")]] base_df <- base_data[[which(base_csv_names=="tripModeProfile_vis_calib")]] } colnames(build_df) <- colnames(base_df) # change purpose names to standard format base_df$purpose <- as.character(base_df$purpose) build_df$purpose <- as.character(build_df$purpose) base_df$purpose <- purpose_type_df$name[match(base_df$purpose, purpose_type_df$code)] build_df$purpose <- purpose_type_df$name[match(build_df$purpose, purpose_type_df$code)] sd.purpose <- get_standardDF(data_df1=base_df, data_df2=build_df, x="tripmode", y = c("value"), grp = "grp_var", shared = T) p <- plotly_bar_plotter(data = sd.purpose, height = 700, xlabel = "Trip Mode", ylabel = "Percent", ynames = c(BASE_SCENARIO_NAME, BUILD_SCENARIO_NAME), percent = T, tickvals = seq(1,length(tripMode)), ticktext = tripMode, bottom_offset = 75) bscols(widths=c(12), list(filter_select("tripMode1", "Select Tour Purpose", sd.purpose, ~purpose,multiple=F), filter_select("tripMode1", "Select Tour Mode", sd.purpose, ~tourmode,multiple=F)) ) ``` Chart Column 2 {data-width=800} -------------------------------------------- ### ```{r tripMode2} bscols(widths=c(12), list(p) ) ``` Count vs Volume: All Day{data-navmenu="Assignment"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Link level count comparison** Results of auto assignment. Comparison of observed counts and assigned volumes on each link with a counted volume, by assignment time period. Chart Column 2{.tabset} -------------------------------------------- ### Count vs Volume - All Links{data-height=575} ```{r count_vol_dy} ggplot(hnet[hnet$DY_CNT > 0,], aes(x = DY_CNT, y = DY_ASN)) + geom_point() + geom_abline(slope = 1, intercept = 0, color = "red") + scale_x_continuous("Daily Count", labels = comma) + scale_y_continuous("Daily Assignment", labels = comma) ``` ### RMSE Statistics{data-height=575} ```{r rmse_vol_dy} ggplot(vgsum, aes(x = vgidx, y = prmse_DAILY, color = "Model")) + geom_line(stat = "identity", size = 1.2) + geom_line(aes(y = limit/100, color = "Limit"), stat = "identity", size = 1.2) + scale_y_continuous("Percent RMSE", labels = percent) + scale_x_continuous("Volume Group", labels = function(x){return(vgsum[x + 1,"vg"])}, breaks = 0:nrow(vgsum)) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) ``` ### Assigned VMT Statistics{data-height=575} ```{r vmtcomp_dy} df = rbind.data.frame(cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$asnvmt_DAILY, "source" = "Model"), cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$obsvmt_DAILY, "source" = "Observed"), stringsAsFactors = FALSE) df$VMT = as.numeric(df$VMT) ggplot(df, aes(x = FTYPE, y = VMT, fill = source)) + geom_bar(stat = "identity", position = "dodge") + scale_x_discrete("") + scale_color_discrete("Source") + scale_y_continuous("Vehicle Miles of Travel", labels = comma) ``` Count vs Volume: NT{data-navmenu="Assignment"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Link level count comparison** Results of auto assignment. Comparison of observed counts and assigned volumes on each link with a counted volume, by assignment time period. Chart Column 2{.tabset} -------------------------------------------- ### NT Count vs Volume - All Links{data-height=575} ```{r count_vol_nt} ggplot(hnet[hnet$NT_CNT > 0,], aes(x = NT_CNT, y = NT_ASN)) + geom_point() + geom_abline(slope = 1, intercept = 0, color = "red") + scale_x_continuous("Night Count", labels = comma) + scale_y_continuous("Night Assignment", labels = comma) ``` ### RMSE Statistics{data-height=575} ```{r rmse_vol_nt} ggplot(vgsum, aes(x = vgidx, y = prmse_NT, color = "Model")) + geom_line(stat = "identity", size = 1.2) + geom_line(aes(y = limit/100, color = "Limit"), stat = "identity", size = 1.2) + scale_y_continuous("Percent RMSE", labels = percent) + scale_x_continuous("Volume Group", labels = function(x){return(vgsum[x + 1,"vg"])}, breaks = 0:nrow(vgsum)) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) ``` ### Assigned VMT Statistics{data-height=575} ```{r vmtcomp_nt} df = rbind.data.frame(cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$asnvmt_NT, "source" = "Model"), cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$obsvmt_NT, "source" = "Observed"), stringsAsFactors = FALSE) df$VMT = as.numeric(df$VMT) ggplot(df, aes(x = FTYPE, y = VMT, fill = source)) + geom_bar(stat = "identity", position = "dodge") + scale_x_discrete("") + scale_color_discrete("Source") + scale_y_continuous("Vehicle Miles of Travel", labels = comma) ``` Count vs Volume: EA{data-navmenu="Assignment"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Link level count comparison** Results of auto assignment. Comparison of observed counts and assigned volumes on each link with a counted volume, by assignment time period. Chart Column 2{.tabset} -------------------------------------------- ### EA Count vs Volume - All Links{data-height=575} ```{r count_vol_ea} ggplot(hnet[hnet$EA_CNT > 0,], aes(x = EA_CNT, y = EA_ASN)) + geom_point() + geom_abline(slope = 1, intercept = 0, color = "red") + scale_x_continuous("Early Morning Count", labels = comma) + scale_y_continuous("Early Morning Assignment", labels = comma) ``` ### RMSE Statistics{data-height=575} ```{r rmse_vol_ea} ggplot(vgsum, aes(x = vgidx, y = prmse_EA, color = "Model")) + geom_line(stat = "identity", size = 1.2) + geom_line(aes(y = limit/100, color = "Limit"), stat = "identity", size = 1.2) + scale_y_continuous("Percent RMSE", labels = percent) + scale_x_continuous("Volume Group", labels = function(x){return(vgsum[x + 1,"vg"])}, breaks = 0:nrow(vgsum)) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) ``` ### Assigned VMT Statistics{data-height=575} ```{r vmtcomp_ea} df = rbind.data.frame(cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$asnvmt_EA, "source" = "Model"), cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$obsvmt_EA, "source" = "Observed"), stringsAsFactors = FALSE) df$VMT = as.numeric(df$VMT) ggplot(df, aes(x = FTYPE, y = VMT, fill = source)) + geom_bar(stat = "identity", position = "dodge") + scale_x_discrete("") + scale_color_discrete("Source") + scale_y_continuous("Vehicle Miles of Travel", labels = comma) ``` Count vs Volume: AM{data-navmenu="Assignment"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Link level count comparison** Results of auto assignment. Comparison of observed counts and assigned volumes on each link with a counted volume, by assignment time period. Chart Column 2{.tabset} -------------------------------------------- ### AM Count vs Volume - All Links{data-height=575} ```{r couAM_vol_am} ggplot(hnet[hnet$AM_CNT > 0,], aes(x = AM_CNT, y = AM_ASN)) + geom_point() + geom_abline(slope = 1, intercept = 0, color = "red") + scale_x_continuous("AM Peak Count", labels = comma) + scale_y_continuous("AM Peak Assignment", labels = comma) ``` ### RMSE Statistics{data-height=575} ```{r rmse_vol_am} ggplot(vgsum, aes(x = vgidx, y = prmse_AM, color = "Model")) + geom_line(stat = "identity", size = 1.2) + geom_line(aes(y = limit/100, color = "Limit"), stat = "identity", size = 1.2) + scale_y_continuous("Percent RMSE", labels = percent) + scale_x_continuous("Volume Group", labels = function(x){return(vgsum[x + 1,"vg"])}, breaks = 0:nrow(vgsum)) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) ``` ### Assigned VMT Statistics{data-height=575} ```{r vmtcomp_am} df = rbind.data.frame(cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$asnvmt_AM, "source" = "Model"), cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$obsvmt_AM, "source" = "Observed"), stringsAsFactors = FALSE) df$VMT = as.numeric(df$VMT) ggplot(df, aes(x = FTYPE, y = VMT, fill = source)) + geom_bar(stat = "identity", position = "dodge") + scale_x_discrete("") + scale_color_discrete("Source") + scale_y_continuous("Vehicle Miles of Travel", labels = comma) ``` Count vs Volume: MM{data-navmenu="Assignment"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Link level count comparison** Results of auto assignment. Comparison of observed counts and assigned volumes on each link with a counted volume, by assignment time period. Chart Column 2{.tabset} -------------------------------------------- ### MM Count vs Volume - All Links{data-height=575} ```{r count_vol_mm} ggplot(hnet[hnet$MM_CNT > 0,], aes(x = MM_CNT, y = MM_ASN)) + geom_point() + geom_abline(slope = 1, intercept = 0, color = "red") + scale_x_continuous("Mid Morning Count", labels = comma) + scale_y_continuous("Mid Morning Assignment", labels = comma) ``` ### RMSE Statistics{data-height=575} ```{r rmse_vol_mm} ggplot(vgsum, aes(x = vgidx, y = prmse_MM, color = "Model")) + geom_line(stat = "identity", size = 1.2) + geom_line(aes(y = limit/100, color = "Limit"), stat = "identity", size = 1.2) + scale_y_continuous("Percent RMSE", labels = percent) + scale_x_continuous("Volume Group", labels = function(x){return(vgsum[x + 1,"vg"])}, breaks = 0:nrow(vgsum)) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) ``` ### Assigned VMT Statistics{data-height=575} ```{r vmtcomp_mm} df = rbind.data.frame(cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$asnvmt_MM, "source" = "Model"), cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$obsvmt_MM, "source" = "Observed"), stringsAsFactors = FALSE) df$VMT = as.numeric(df$VMT) ggplot(df, aes(x = FTYPE, y = VMT, fill = source)) + geom_bar(stat = "identity", position = "dodge") + scale_x_discrete("") + scale_color_discrete("Source") + scale_y_continuous("Vehicle Miles of Travel", labels = comma) ``` Count vs Volume: MD{data-navmenu="Assignment"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Link level count comparison** Results of auto assignment. Comparison of observed counts and assigned volumes on each link with a counted volume, by assignment time period. Chart Column 2{.tabset} -------------------------------------------- ### MD Count vs Volume - All Links{data-height=575} ```{r count_vol_md} ggplot(hnet[hnet$MD_CNT > 0,], aes(x = MD_CNT, y = MD_ASN)) + geom_point() + geom_abline(slope = 1, intercept = 0, color = "red") + scale_x_continuous("Midday Count", labels = comma) + scale_y_continuous("Midday Assignment", labels = comma) ``` ### RMSE Statistics{data-height=575} ```{r rmse_vol_md} ggplot(vgsum, aes(x = vgidx, y = prmse_MD, color = "Model")) + geom_line(stat = "identity", size = 1.2) + geom_line(aes(y = limit/100, color = "Limit"), stat = "identity", size = 1.2) + scale_y_continuous("Percent RMSE", labels = percent) + scale_x_continuous("Volume Group", labels = function(x){return(vgsum[x + 1,"vg"])}, breaks = 0:nrow(vgsum)) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) ``` ### Assigned VMT Statistics{data-height=575} ```{r vmtcomp_md} df = rbind.data.frame(cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$asnvmt_MD, "source" = "Model"), cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$obsvmt_MD, "source" = "Observed"), stringsAsFactors = FALSE) df$VMT = as.numeric(df$VMT) ggplot(df, aes(x = FTYPE, y = VMT, fill = source)) + geom_bar(stat = "identity", position = "dodge") + scale_x_discrete("") + scale_color_discrete("Source") + scale_y_continuous("Vehicle Miles of Travel", labels = comma) ``` Count vs Volume: AF{data-navmenu="Assignment"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Link level count comparison** Results of auto assignment. Comparison of observed counts and assigned volumes on each link with a counted volume, by assignment time period. Chart Column 2{.tabset} -------------------------------------------- ### AF Count vs Volume - All Links{data-height=575} ```{r count_vol_af} ggplot(hnet[hnet$AF_CNT > 0,], aes(x = AF_CNT, y = AF_ASN)) + geom_point() + geom_abline(slope = 1, intercept = 0, color = "red") + scale_x_continuous("Afternoon Count", labels = comma) + scale_y_continuous("Afternoon Assignment", labels = comma) ``` ### RMSE Statistics{data-height=575} ```{r rmse_vol_af} ggplot(vgsum, aes(x = vgidx, y = prmse_AF, color = "Model")) + geom_line(stat = "identity", size = 1.2) + geom_line(aes(y = limit/100, color = "Limit"), stat = "identity", size = 1.2) + scale_y_continuous("Percent RMSE", labels = percent) + scale_x_continuous("Volume Group", labels = function(x){return(vgsum[x + 1,"vg"])}, breaks = 0:nrow(vgsum)) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) ``` ### Assigned VMT Statistics{data-height=575} ```{r vmtcomp_af} df = rbind.data.frame(cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$asnvmt_AF, "source" = "Model"), cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$obsvmt_AF, "source" = "Observed"), stringsAsFactors = FALSE) df$VMT = as.numeric(df$VMT) ggplot(df, aes(x = FTYPE, y = VMT, fill = source)) + geom_bar(stat = "identity", position = "dodge") + scale_x_discrete("") + scale_color_discrete("Source") + scale_y_continuous("Vehicle Miles of Travel", labels = comma) ``` Count vs Volume: PM{data-navmenu="Assignment"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Link level count comparison** Results of auto assignment. Comparison of observed counts and assigned volumes on each link with a counted volume, by assignment time period. Chart Column 2{.tabset} -------------------------------------------- ### PM Count vs Volume - All Links{data-height=575} ```{r count_vol_pm} ggplot(hnet[hnet$PM_CNT > 0,], aes(x = PM_CNT, y = PM_ASN)) + geom_point() + geom_abline(slope = 1, intercept = 0, color = "red") + scale_x_continuous("PM Peak Count", labels = comma) + scale_y_continuous("PM Peak Assignment", labels = comma) ``` ### RMSE Statistics{data-height=575} ```{r rmse_vol_pm} ggplot(vgsum, aes(x = vgidx, y = prmse_PM, color = "Model")) + geom_line(stat = "identity", size = 1.2) + geom_line(aes(y = limit/100, color = "Limit"), stat = "identity", size = 1.2) + scale_y_continuous("Percent RMSE", labels = percent) + scale_x_continuous("Volume Group", labels = function(x){return(vgsum[x + 1,"vg"])}, breaks = 0:nrow(vgsum)) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) ``` ### Assigned VMT Statistics{data-height=575} ```{r vmtcomp_pm} df = rbind.data.frame(cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$asnvmt_PM, "source" = "Model"), cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$obsvmt_PM, "source" = "Observed"), stringsAsFactors = FALSE) df$VMT = as.numeric(df$VMT) ggplot(df, aes(x = FTYPE, y = VMT, fill = source)) + geom_bar(stat = "identity", position = "dodge") + scale_x_discrete("") + scale_color_discrete("Source") + scale_y_continuous("Vehicle Miles of Travel", labels = comma) ``` Count vs Volume: EV{data-navmenu="Assignment"} ============================================ Description {.sidebar data-width=175} -------------------------------------------- ******** **Link level count comparison** Results of auto assignment. Comparison of observed counts and assigned volumes on each link with a counted volume, by assignment time period. Chart Column 2{.tabset} -------------------------------------------- ### EV Count vs Volume - All Links{data-height=575} ```{r count_vol_ev} ggplot(hnet[hnet$EV_CNT > 0,], aes(x = EV_CNT, y = EV_ASN)) + geom_point() + geom_abline(slope = 1, intercept = 0, color = "red") + scale_x_continuous("Evening Count", labels = comma) + scale_y_continuous("Evening Assignment", labels = comma) ``` ### RMSE Statistics{data-height=575} ```{r rmse_vol_ev} ggplot(vgsum, aes(x = vgidx, y = prmse_EV, color = "Model")) + geom_line(stat = "identity", size = 1.2) + geom_line(aes(y = limit/100, color = "Limit"), stat = "identity", size = 1.2) + scale_y_continuous("Percent RMSE", labels = percent) + scale_x_continuous("Volume Group", labels = function(x){return(vgsum[x + 1,"vg"])}, breaks = 0:nrow(vgsum)) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) ``` ### Assigned VMT Statistics{data-height=575} ```{r vmtcomp_ev} df = rbind.data.frame(cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$asnvmt_EV, "source" = "Model"), cbind("FTYPE" = vmtcomp$FTYPE, "VMT" = vmtcomp$obsvmt_EV, "source" = "Observed"), stringsAsFactors = FALSE) df$VMT = as.numeric(df$VMT) ggplot(df, aes(x = FTYPE, y = VMT, fill = source)) + geom_bar(stat = "identity", position = "dodge") + scale_x_discrete("") + scale_color_discrete("Source") + scale_y_continuous("Vehicle Miles of Travel", labels = comma) ```